(** * Imp: Simple Imperative Programs *)

Set Warnings "-notation-overridden,-parsing".
From Coq Require Import Bool.Bool.
From Coq Require Import Init.Nat.
From Coq Require Import Arith.Arith.
From Coq Require Import Arith.EqNat.
From Coq Require Import Lia.
From Coq Require Import Lists.List.
From Coq Require Import Strings.String.
Import ListNotations.
From QuickChick Require Import QuickChick.
Import QcNotation QcDefaultNotation.
Require Export ExtLib.Structures.Monads.
Export MonadNotation. Open Scope monad_scope.
Open Scope qc_scope.
Require Import
        Coq.FSets.FMapList
        Coq.Structures.OrderedTypeEx
        Coq.FSets.FMapFacts.

Module Import M := FMapList.Make(String_as_OT).

(* Instantiate a map type using strings as keys *)
Module P := WProperties_fun String_as_OT M.
Module F := P.F.

(* Optionals are moands  *)
Instance option_monad : Monad option :=
  {
  ret X v := @Some X v;
  bind T U mt f :=
    match mt with
    | Some v => f v
    | None => None
  end
  }.

(* some list combinators *)
Fixpoint foldr {X B}
           (f : X -> B -> B) (b : B) (l : list X) : B :=
  match l with
  | [] => b
  | (x::l) => (f x (foldr f b l))
  end.

Definition andmap {X} (p : X -> bool) :=
  foldr (fun x b => (p x) && b) true.

Definition ormap {X} (p : X -> bool) :=
  foldr (fun x b => (p x) || b) false.

Fixpoint zip {X Y} (l1 : list X) (l2 : list Y)
  : list (X * Y) :=
  match l1, l2 with
  | _, [] => []
  | [], _ => []
  | (x::xs), (y::ys) => (x,y) :: (zip xs ys)
end.

Open Scope string_scope.
Instance string_arb : Gen string :=
  {
  arbitrary := ret "random"
  }.
Instance shrink_str : Shrink string :=
  {
  shrink s := []
  }.
Close Scope string_scope.

(* ================================================================= *)
(* Labels, for controlling priviledge *)

Inductive label : Type :=
  | Secret
  | Public.

Derive (Arbitrary, Show) for label.
Instance eq_dec_label (l1 l2 : label) : Dec (l1 = l2).
Proof. dec_eq. Defined.

(* Reflection setup *)
Definition label_eqb l1 l2 :=
  match l1, l2 with
| Secret, Secret => true
| Public, Public => true
| _, _ => false
  end.

Definition label_eqb_eq : forall l1 l2,
    label_eqb l1 l2 = true -> l1 = l2.
Proof.
  intros.
  destruct l1; destruct l2; auto; inversion H.
Qed.

Definition label_eqb_neq : forall l1 l2,
    label_eqb l1 l2 = false -> l1 <> l2.
Proof.
  intros.
  destruct l1; destruct l2; auto; congruence.
Qed.

Definition merge (l1 l2 : label) : label :=
  match l1, l2 with
  | Public, Public => Public
  | _, _ => Secret
  end.

(* Conjecture merge_secret : forall l, merge l Secret = Secret. *)
(* QuickChick merge_secret. *)

Theorem merge_secret : forall l1,
    merge l1 Secret = Secret.
Proof.
  intros. destruct l1; auto.
Qed.

Theorem merge_public : forall l1,
    merge l1 Public = l1.
Proof.
  intros.
  destruct l1; auto.
Qed.

Theorem merge_commutative : forall l1 l2,
    merge l1 l2 = merge l2 l1.
Proof.
  destruct l1; destruct l2; auto.
Qed.

(* This class drives the entire implementation of IFC-Imp *)

Class Distinguishable X :=
  {
  indist : X -> X -> Prop
  }.

Notation "x1 == x2" := (indist x1 x2)
                         (at level 40).

Definition value (X:Type) : Type := (X * label).

Instance value_indist {X} : Distinguishable (value X) :=
  {
  indist x1 x2 :=
    match x1, x2 with
    | (_, Secret), (_, Secret) => True
    | (n1, Public), (n2, Public) => n1 = n2
    | _, _ => False
    end
  }.

Definition nat_value : Type := value nat.

Instance dec_value_indist (v1 v2 : nat_value) :
  Dec (v1 == v2).
Proof.
  constructor. unfold ssrbool.decidable.
  destruct v1. destruct v2.
  destruct l; destruct l0;
    try (right; auto; fail).
  - left. simpl. tauto.
  - destruct (Nat.eqb n n0) eqn:Heq.
    + apply Nat.eqb_eq in Heq.
      subst. left. simpl. auto.
    + apply Nat.eqb_neq in Heq. right. simpl. auto.
Qed.

Definition bool_value : Type := value bool.

Instance bool_value_indist (v1 v2 : bool_value) :
  Dec (v1 == v2).
Proof.
  constructor. unfold ssrbool.decidable.
  destruct v1. destruct v2.
  destruct l; destruct l0;
    try (right; auto; fail).
  - left. simpl. tauto.
  - destruct (Bool.eqb b b0) eqn:Heq.
    + assert (b = b0).
      apply Bool.eqb_eq. unfold Is_true. rewrite Heq. tauto.
      subst. left. simpl. auto.
    + assert (b <> b0).
      apply Bool.eqb_false_iff. assumption.
      right. simpl. assumption.
Qed.

Definition state := M.t nat_value.
Close Scope string_scope.

Instance indist_state : Distinguishable state :=
  {
  indist s1 s2 := forall (x1 : string) (v1 v2: nat_value),
        (MapsTo x1 v1 s1 ->
         (exists (v2' : nat_value),
             MapsTo x1 v2' s2 /\ v1 == v2'))
        /\
        (MapsTo x1 v2 s2 ->
         exists (v1' : nat_value),
           MapsTo x1 v1' s1 /\ v1' == v2)
  }.

Theorem indist_comm : forall (st1 st2 : state),
    st1 == st2 -> st2 == st1.
Proof.
  intros.
  unfold "==". simpl.
  intros.
  split.
  - intros.
    simpl "==" in H. simpl in H.
    destruct H with
        (x1 := x1)
        (v1 := v2)
        (v2 := v1).
    destruct H2 as [v1']. assumption.
    clear H1. clear H.
    destruct H2.
    exists v1'. split.
    + assumption.
    + destruct v1'. destruct v1.
      destruct l; destruct l0;
        try assumption; auto.
  - intros.
    simpl "==" in H.
    destruct H with
        (x1 := x1)
        (v1 := v2)
        (v2 := v1).
    clear H2. clear H.
    destruct H1 as [v2']. assumption.
    destruct H.
    exists v2'. split.
    + assumption.
    + destruct v2'. destruct v2.
      destruct l; destruct l0;
        try assumption; auto.
Qed.

Theorem indist_trans : forall (st1 st2 st3 : state),
    st1 == st2 ->
    st2 == st3 ->
    st1 == st3.
Proof.
  intros.
  simpl "==". intros.
  split.
  - intros.
    simpl "==" in *.
    specialize (H x1 v1 v2).
    destruct H. destruct H as [v2']. assumption.
    destruct H. clear H2.
    specialize (H0 x1 v2' v2).
    destruct H0. destruct H0 as [ v2'0 ]. assumption.
    destruct H0. exists v2'0. split.
    + assumption.
    + destruct v1. destruct v2'0. destruct v2.
      destruct v2'.
      destruct l; destruct l0;
        destruct l1; destruct l2; try assumption;
          try tauto; try (exfalso; assumption);
            subst; auto.
  - intros.
    simpl "==" in *.
    specialize (H0 x1 v1 v2).
    destruct H0. destruct H2 as [v1']. assumption.
    destruct H2.
    specialize (H x1 v1 v1').
    destruct H. destruct H4 as [v2']. assumption.
    destruct H4. exists v2'. split.
    + assumption.
    + destruct v2'. destruct v2. destruct v1'. destruct v1.
      destruct l; destruct l0; destruct l1; destruct l2;
        try tauto;
        try (exfalso; assumption);
        subst; auto.
Qed.

Inductive aexp : Type :=
  | ANum (n : nat)
  | AId (x : string)
  | APlus (a1 a2 : aexp)
  | AMinus (a1 a2 : aexp)
  | AMult (a1 a2 : aexp).

Instance aexp_dec_eq (a1 a2 : aexp) :
  Dec (a1 = a2).
Proof. dec_eq. Defined.
Derive (Show, Shrink, Arbitrary) for aexp.

Definition W : string := "W".
Definition X : string := "X".
Definition Y : string := "Y".
Definition Z : string := "Z".

Inductive bexp : Type :=
  | BTrue
  | BFalse
  | BEq (a1 a2 : aexp)
  | BLe (a1 a2 : aexp)
  | BNot (b : bexp)
  | BAnd (b1 b2 : bexp).
Instance bexp_eq_dec (b1 b2 : bexp) :
  Dec (b1 = b2).
Proof. dec_eq. Defined.
Derive (Show, Shrink, Arbitrary) for bexp.

Coercion AId : string >-> aexp.
Coercion ANum : nat >-> aexp.

Declare Custom Entry com.
Declare Scope com_scope.
Notation "<{ e }>" := e (at level 0, e custom com at level 99) : com_scope.
Notation "( x )" := x (in custom com, x at level 99) : com_scope.
Notation "x" := x (in custom com at level 0, x constr at level 0) : com_scope.
Notation "f x .. y" := (.. (f x) .. y)
                  (in custom com at level 0, only parsing,
                  f constr at level 0, x constr at level 9,
                  y constr at level 9) : com_scope.
Notation "x + y" := (APlus x y) (in custom com at level 50, left associativity).
Notation "x - y" := (AMinus x y) (in custom com at level 50, left associativity).
Notation "x * y" := (AMult x y) (in custom com at level 40, left associativity).
Notation "'true'"  := true (at level 1).
Notation "'true'"  := BTrue (in custom com at level 0).
Notation "'false'"  := false (at level 1).
Notation "'false'"  := BFalse (in custom com at level 0).
Notation "x <= y" := (BLe x y) (in custom com at level 70, no associativity).
Notation "x = y"  := (BEq x y) (in custom com at level 70, no associativity).
Notation "x && y" := (BAnd x y) (in custom com at level 80, left associativity).
Notation "'~' b"  := (BNot b) (in custom com at level 75, right associativity).

Open Scope com_scope.

Definition example_aexp : aexp := <{ 3 + (X * 2) }>.
Definition example_bexp : bexp := <{ true && ~(X <= 4) }>.

Close Scope string_scope.
(* ================================================================= *)
(** ** Evaluation *)

Inductive aevalR : state -> aexp -> nat_value -> Prop :=
  | A_Value : forall state (n : nat),
      aevalR state (ANum n) (n, Public)
  | A_Id : forall state x v,
      MapsTo x v state ->
      aevalR state (AId x) v
  | A_EPlus : forall state a1 a2 n1 n2 l1 l2,
      aevalR state a1 (n1, l1) ->
      aevalR state a2 (n2, l2) ->
      aevalR state <{a1 + a2}> (n1 + n2, merge l1 l2)
  | A_EMinus : forall state a1 a2 n1 n2 l1 l2,
      aevalR state a1 (n1, l1) ->
      aevalR state a2 (n2, l2) ->
      aevalR state <{a1 - a2}> (n1 - n2, merge l1 l2)
  | A_EMult : forall state a1 a2 n1 n2 l1 l2,
      aevalR state a1 (n1, l1) ->
      aevalR state a2 (n2, l2) ->
      aevalR state <{a1 * a2}> (n1 * n2, merge l1 l2).

Fixpoint aeval (fuel : nat) (st : state) (a : aexp) : option nat_value :=
  match fuel with
| 0 => None
| S n' => match a with
       | (ANum n) => Some (n, Public)
       | (AId x) => find x st
       | (APlus a1 a2) =>
         '(n1, l1) <- aeval n' st a1;;
         '(n2, l2) <- aeval n' st a2;;
         ret (n1 + n2, merge l1 l2)
       | (AMinus a1 a2) =>
         '(n1, l1) <- aeval n' st a1;;
         '(n2, l2) <- aeval n' st a2;;
         ret (n1 - n2, merge l1 l2)
       | (AMult a1 a2) =>
         '(n1, l1) <- aeval n' st a1;;
         '(n2, l2) <- aeval n' st a2;;
         ret (n1 * n2, merge l1 l2)
         end
  end.

Theorem aeval_implies_aevalR : forall fuel st a v,
    aeval fuel st a = Some v ->
    aevalR st a v.
Proof.
  intros.
  generalize dependent st.
  generalize dependent fuel.
  generalize dependent v.
  induction a; intros;
    try destruct fuel; try (inversion H).
  - apply A_Value.
  - apply A_Id. apply find_2. assumption.
  - destruct (aeval fuel st a1) eqn:Heq1.
    + destruct n as [n1 l2].
      destruct (aeval fuel st a2) eqn:Heq2.
      * destruct n as [n2 l3].
        injection H1. intros. subst.
        apply A_EPlus.
        -- eapply IHa1. eauto.
        -- eapply IHa2. eauto.
      * congruence.
    + congruence.
  - destruct (aeval fuel st a1) eqn:Heq1.
    + destruct n as [n1 l2].
      destruct (aeval fuel st a2) eqn:Heq2.
      * destruct n as [n2 l3].
        injection H1. intros. subst.
        apply A_EMinus.
        -- eapply IHa1. eauto.
        -- eapply IHa2. eauto.
      * congruence.
    + congruence.
  - destruct (aeval fuel st a1) eqn:Heq1.
    + destruct n as [n1 l2].
      destruct (aeval fuel st a2) eqn:Heq2.
      * destruct n as [n2 l3].
        injection H1. intros. subst.
        apply A_EMult.
        -- eapply IHa1. eauto.
        -- eapply IHa2. eauto.
      * congruence.
    + congruence.
Qed.

Inductive bevalR : state -> bexp -> bool_value -> Prop :=
  | E_True : forall st,
      bevalR st <{true}> (true, Public)
  | E_False : forall st,
      bevalR st <{false}> (false, Public)
  | E_Eq : forall st a1 a2 n1 n2 l1 l2,
      aevalR st a1 (n1, l1) ->
      aevalR st a2 (n2, l2) ->
      bevalR st <{a1 = a2}> (n1 =? n2, merge l1 l2)
  | E_Lt : forall st a1 a2 n1 n2 l1 l2,
      aevalR st a1 (n1, l1) ->
      aevalR st a2 (n2, l2) ->
      bevalR st <{a1 <= a2}> (n1 <=? n2, merge l1 l2)
  | E_not__true : forall st b l1,
      bevalR st b (true, l1) ->
      bevalR st <{~ b}> (false, l1)
  | E_not__false : forall st b l1,
      bevalR st b (false, l1) ->
      bevalR st <{~ b}> (true, l1)
  | E_and : forall st b1 b2 bool1 bool2 l1 l2,
      bevalR st b1 (bool1, l1) ->
      bevalR st b2 (bool2, l2) ->
      bevalR st <{b1 && b2}> (bool1 && bool2, merge l1 l2).

Definition empty_st : state := (M.empty nat_value).

Notation "x '!->' v" := (add x v (M.empty nat_value))
                          (at level 100).
Example aexp0 :
  aevalR (X !-> (5, Public)) <{ X * 2 }> (10, Public).
Proof.
  replace (10, Public) with (5 * 2, merge Public Public).
  apply A_EMult.
  apply A_Id.
  apply find_2. auto.
  apply A_Value.
  auto.
Qed.

Example aexp1 :
    aevalR (X !-> (5, Public)) <{ (3 + (X * 2))}> (13, Public).
Proof.
  replace (13, Public) with (3 + 10, merge Public Public).
  apply A_EPlus.
  apply A_Value.
  replace (10, Public) with (5 * 2, merge Public Public).
  apply A_EMult.
  apply A_Id.
  apply find_2. auto.
  apply A_Value.
  auto.
  auto.
Qed.

Example bexp1 :
  bevalR (X !-> (5, Secret)) <{ true && ~(X <= 4)}>
  (true, Secret).
Proof.
  replace (true, Secret) with
      (true && true, merge Public Secret).
  apply E_and.
  apply E_True.
  apply E_not__false.
  replace (false, Secret) with
      (5 <=? 4, merge Secret Public).
  apply E_Lt.
  apply A_Id. apply find_2. auto.
  apply A_Value.
  auto.
  auto.
Qed.

(* ################################################################# *)
(** * Commands *)

(* ================================================================= *)
(** ** Syntax *)

Inductive com : Type :=
  | CSkip
  | CAss (x : string) (a : aexp) (l : label)
  | CSeq (c1 c2 : com)
  | CIf (b : bexp) (c1 c2 : com).
  (* | CWhile (b : bexp) (c : com). *)

Fixpoint com_indist_f c1 c2 :=
  match c1, c2 with
| CSkip, CSkip => True
| CAss x1 a1 Public, CAss x2 a2 Public =>
  x1 = x2 /\ a1 = a2
| CAss x1 a1 Secret, CAss x2 a2 Secret => x1 = x2
| CSeq c1 c2, CSeq c1' c2' =>
  com_indist_f c1 c1' /\ com_indist_f c2 c2'
| CIf b c1 c2, CIf b' c1' c2' =>
  b = b' /\ com_indist_f c1 c1' /\ com_indist_f c2 c2'
| _, _ => False
  end.

Instance com_indist : Distinguishable com :=
  {
  indist := com_indist_f
  }.

Notation "'skip'"  :=
         CSkip (in custom com at level 0) : com_scope.
Notation "x ':=' y ',' l"  :=
         (CAss x y l)
           (in custom com at level 0,
               x constr at level 0,
                y at level 85,
                no associativity) : com_scope.
Notation "x ; y" :=
         (CSeq x y)
           (in custom com at level 90, right associativity) : com_scope.
Notation "'if' x 'then' y 'else' z 'end'" :=
         (CIf x y z)
           (in custom com at level 89, x at level 99,
            y at level 99, z at level 99) : com_scope.
(* Notation "'while' x 'do' y 'end'" := *)
(*          (CWhile x y) *)
(*             (in custom com at level 89, x at level 99, y at level 99) : com_scope. *)

Reserved Notation
         "st '=[' c ']=>' st'"
         (at level 40, c custom com at level 99,
          st constr, st' constr at next level).

Definition sec_context : Type := (state * label).

Instance sec_context_indist : Distinguishable sec_context :=
  {
  indist c1 c2 :=
    match c1, c2 with
    | (s1, l1), (s2, l2) => l2 = l1  /\ indist s1 s2
    end
  }.

Definition merge_list (l : list label) : label :=
  foldr (fun l1 l2 => merge l1 l2) Public l.

Definition writing_valid (x : string) (st : state) (l : label)
  : Prop :=
  (exists (n' : nat) (l' : label),
      l = l' /\
      MapsTo x (n', l') st).

Inductive ceval : com -> sec_context -> sec_context -> Prop :=
  | E_Skip : forall ctxt,
      ctxt=[ skip ]=> ctxt
  | E_Ass  : forall (st : M.t nat_value) a n x l l__v l__s,
      aevalR st a (n, l__v) ->
      In x st ->
      writing_valid x st (merge l__v l) ->
      (st,l) =[ x := a , l__s ]=>
      (add x (n, merge_list [l__v;l__s; l]) st, l)
  | E_Seq : forall c1 c2 ctxt ctxt' ctxt'',
      ctxt  =[ c1 ]=> ctxt'  ->
      ctxt' =[ c2 ]=> ctxt'' ->
      ctxt  =[ c1 ; c2 ]=> ctxt''
  | E_IfTrue : forall st st' b l__guard l__begin c1 c2,
      bevalR st b (true, l__guard) ->
      (st, merge l__begin l__guard) =[ c1 ]=>
    (st', l__begin ) ->
      (st,l__begin) =[ if b then c1 else c2 end]=> (st', l__begin)
  | E_IfFalse : forall st st' l__guard l__begin b c1 c2,
      bevalR st b (false, l__guard) ->
      (st, merge l__begin l__guard) =[ c2 ]=>
    (st', merge l__begin l__guard) ->
      (st, l__begin) =[ if b then c1 else c2 end]=> (st', l__begin)
  where "st =[ c ]=> st'" := (ceval c st st').
  (* | E_WhileFalse : forall b st c, *)
  (*     beval st b = false -> *)
  (*     st =[ while b do c end ]=> st *)
  (* | E_WhileTrue : forall st st' st'' b c, *)
  (*     beval st b = true -> *)
  (*     st  =[ c ]=> st' -> *)
  (*     st' =[ while b do c end ]=> st'' -> *)
  (*     st  =[ while b do c end ]=> st'' *)

Definition default_ctxt (xs : list (string * label)) :
  sec_context :=

  let st :=
      foldr (fun '(x, l) st => add x (0, l) st)
            (M.empty nat_value) xs in
  (st, Public).

Definition v_eq (v1 v2 : nat_value) : bool :=
  match v1, v2 with
  | (n1, l1), (n2, l2) => (l1 = l2 ?) && (n1 =? n2)
  end.

Definition build_st (entries : list (string * (nat * label)))
  : M.t nat_value :=
  foldr
    (fun '(key, value) m' => add key value m')
    (empty nat_value)
    entries.

Definition ceval_example1state : sec_context :=
  default_ctxt [(X, Public); (Y, Public); (Z, Public)].

Example ceval_example1:
  ceval_example1state =[
     X := 2, Public;
     if (X <= 1)
       then Y := 3, Public
       else Z := 4, Public
     end
  ]=> (build_st [(Z, (4, Public));(X, (2, Public)); (Y, (0, Public))], Public).
Proof.
  remember (add X (0, Public) (add Y (0, Public) (Z !-> (0, Public)))).
  eapply E_Seq.
  - eapply E_Ass.
    + simpl. rewrite <- Heqt0.
      exact (A_Value t0 2).
    + simpl. apply mem_2. auto.
    + simpl. rewrite <- Heqt0.
      unfold writing_valid.
      Admitted.

Lemma public_indist : forall {X} (n : X),
    (n, Public) == (n, Public).
Proof.
  intros.
  unfold indist. simpl.
  reflexivity.
Qed.

Lemma secret_indist : forall {X} (n1 n2 : X),
    (n1, Secret) == (n2, Secret).
Proof.
  intros.
  unfold indist. simpl. tauto.
Qed.

Lemma diff_dist : forall {X} (n1 n2 : X),
    not ((n1, Secret) == (n2, Public)).
Proof.
  intros. unfold not. intros.
  unfold indist in H. simpl in H.
  auto.
Qed.

Lemma indist_commut :
  forall {X:Type} `{forall (x1 x2 : X), Dec (x1 = x2)}
    (n1 n2 : X) (l1 l2 : label),
    (n1, l1) == (n2, l2) ->
    (n2, l2) == (n1, l1).
Proof.
  intros.
  unfold indist in H. simpl in H0.
  destruct l1; destruct l2.
  - apply secret_indist.
  - apply H0.
  - apply H0.
  - specialize (H n1 n2). destruct H.
    destruct dec.
    + rewrite H0. apply public_indist.
    + congruence.
Qed.

Lemma MapsTo_eq :
  forall (st : state) (x : string) (v1 v2 : nat_value),
    MapsTo x v1 st ->
    MapsTo x v2 st ->
    v1 = v2.
Proof.
  intros.
  apply find_1 in H.
  apply find_1 in H0. rewrite H0 in H. injection H.
  intros. auto.
Qed.

Lemma map_add_eq :
  forall (st : state) (x : string) (v1 v2 : nat_value),
    MapsTo x v1 (add x v2 st) ->
    v1 = v2.
Proof.
  intros.
  assert (MapsTo x v2 (add x v2 st)).
  {
    apply add_1. reflexivity.
  }
  apply MapsTo_eq with (st := add x v2 st) (x := x);
    assumption.
Qed.

Lemma indist_implies_indist :
  forall (st1 st2 : state) (x : string) (v1 v2 : nat_value),
    st1 == st2 ->
    MapsTo x v1 st1 ->
    MapsTo x v2 st2 ->
    v1 == v2.
Proof.
  intros. simpl "==" in H.
  specialize (H x v1 v2).
  destruct H. destruct H as [v2']. assumption.
  destruct H.
  replace v2' with v2 in *.
  - destruct v1. destruct v2.
    destruct l; destruct l0;
      try tauto;
      try (exfalso; assumption);
      subst; auto.
  - apply MapsTo_eq with (st := st2) (x := x);
      assumption.
Qed.

Theorem indist_split : forall {X} (n1 n2 : X) (l1 l2 : label),
    (n1, l1) == (n2, l2) ->
    (l1 = Secret /\ l2 = Secret) \/
    (l1 = Public /\ l2 = Public /\ n1 = n2).
Proof.
  intros.
  destruct l1; destruct l2;
    auto;
    contradict H.
Qed.

Theorem aexp_EENI :
  forall (st1 st2 : state) (a : aexp) (v1 v2 : nat_value),
    st1 == st2 ->
    aevalR st1 a v1 ->
    aevalR st2 a v2 ->
    v1 == v2.
Proof.
  intros.
  generalize dependent v1.
  generalize dependent v2.
  induction a; intros;
    inversion H0; inversion H1; subst;
    try (
       assert ((n1, l1) == (n0, l0)); auto;
    assert ((n2, l2) == (n3, l3)); auto;
    apply indist_split in H2;
    apply indist_split in H3;
    destruct H2; destruct H3;
      destruct H2 as [Hl1 Hl0];
      destruct H3 as [Hl2 Hl3];
      subst; simpl; try tauto;
        destruct Hl0; subst; simpl; try tauto;
          destruct Hl3; subst; simpl; tauto).
  - apply public_indist.
  - eapply indist_implies_indist.
    apply H. apply H4. apply H8.
Qed.

Theorem bexp_EENI :
  forall (st1 st2 : state) (b : bexp) (v1 v2 : bool_value),
    st1 == st2 ->
    bevalR st1 b v1 ->
    bevalR st2 b v2 ->
    v1 == v2.
Proof.
  intros.
  generalize dependent v1.
  generalize dependent v2.
  induction b; intros;
    inversion H0; inversion H1; subst;
      try (apply public_indist).
  -
    assert ((n1, l1) == (n0, l0)).
    apply aexp_EENI with
        (st1 := st1)
        (st2 := st2)
        (a := a1); assumption.
    assert ((n2, l2) == (n3, l3)).
    apply aexp_EENI with
        (st1 := st1)
        (st2 := st2)
        (a := a2); assumption.
    apply indist_split in H2.
    apply indist_split in H3.
    destruct H2; destruct H3;
      destruct H2; destruct H3; subst; simpl; try tauto;
        destruct H4; subst; simpl; try tauto;
          destruct H6; subst; auto; tauto.
  - assert ((n1, l1) == (n0, l0)).
    apply aexp_EENI with
        (st1 := st1)
        (st2 := st2)
        (a := a1); assumption.
    assert ((n2, l2) == (n3, l3)).
    apply aexp_EENI with
        (st1 := st1)
        (st2 := st2)
        (a := a2); assumption.
    apply indist_split in H2.
    apply indist_split in H3.
    destruct H2; destruct H3;
      destruct H2; destruct H3; subst; simpl; try tauto;
        destruct H4; subst; simpl; try tauto;
          destruct H6; subst; simpl; tauto.
  - assert ((true, l1) == (true, l0)).
    apply IHb; assumption.
    apply indist_split in H2.
    destruct H2.
    + destruct H2. subst. apply secret_indist.
    + destruct H2. destruct H3. subst. apply public_indist.
  - assert ((true, l1) == (false, l0)).
    apply IHb; assumption.
    apply indist_split in H2.
    destruct H2.
    + destruct H2. subst. apply secret_indist.
    + destruct H2 as [_ [_ Contra]]. congruence.
  - assert ((false, l1) == (true, l0)).
    apply IHb; assumption.
    apply indist_split in H2.
    destruct H2.
    + destruct H2. subst. apply secret_indist.
    + destruct H2 as [_ [_ Contra]]. congruence.
  - assert ((false, l1) == (false, l0)).
    apply IHb; assumption.
    apply indist_split in H2.
    destruct H2.
    + destruct H2. subst. apply secret_indist.
    + destruct H2 as [H21 [H22 H23]].
      subst. simpl. tauto.
  - assert ((bool1, l1) == (bool0, l0)).
    apply IHb1; assumption.
    assert ((bool2, l2) == (bool3, l3)).
    apply IHb2; assumption.
    apply indist_split in H2.
    apply indist_split in H3.
    destruct H2; destruct H3;
      destruct H2; destruct H3; subst; simpl; try tauto;
        destruct H4; subst; simpl; try tauto.
    destruct H6. subst. simpl. tauto.
Qed.

Theorem secret_doms : forall (ls : list label),
    List.In Secret ls ->
    merge_list ls = Secret.
Proof.
  intros.
  unfold merge_list.
  induction ls as [| l ls' IH].
  - inversion H.
  - destruct l.
    + auto.
    + assert (List.In Secret ls').
      {
        inversion H.
        + congruence.
        + assumption.
      }
      simpl.
      assert
        ((foldr (fun l1 l2 : label => merge l1 l2) Public ls')
         = Secret).
      apply IH. assumption.
      rewrite H1. reflexivity.
Qed.

Theorem map_add_congruence : forall (l1 l2 : label) (n1 n2 : nat)
                               (st : state) (x : string),
    l1 <> l2 ->
    MapsTo x (n1, l1) (add x (n2, l2) st) ->
    False.
Proof.
  intros.
  assert (MapsTo x (n2, l2) (add x (n2, l2) st)).
  {
    apply add_1. auto.
  }
  assert ((n1, l1) = (n2, l2)).
  {
    apply MapsTo_eq with
        (st := (add x (n2, l2) st))
        (x := x); auto.
  }
  injection H2. intros. congruence.
Qed.

(* the no wrote down rule is sound*)
Theorem add_secret :
  forall (x : string) (n : nat) (st : state),
    writing_valid x st Secret ->
    st == (add x (n, Secret) st).
Proof.
  intros.
  unfold writing_valid in H.
  destruct H as [n']. destruct H as [l']. destruct H.
  subst. simpl "==". intros.
  destruct (String.eqb x x1) eqn:Heq.
  - apply String.eqb_eq in Heq.
    split.
    + intros. exists (n, Secret).
      split; subst.
      * apply add_1. auto.
      * destruct v1. destruct l.
        -- tauto.
        -- assert ((n', Secret) = (n0, Public)).
           {
             apply MapsTo_eq with (st := st) (x := x1);
               assumption.
           }
           injection H1. intros. congruence.
    + intros. subst.
      exists (n', Secret). destruct v1. destruct v2.
      split.
      * assumption.
      * destruct l; destruct l0;
          try tauto; try (exfalso; assumption);
            apply map_add_congruence with
                (l1 := Public)
                (l2 := Secret)
                (n1 := n1)
                (n2 := n)
                (st := st)
                (x := x1); auto; discriminate.
  - apply String.eqb_neq in Heq.
    split.
    + intros. exists v1. split.
      * apply add_2; assumption.
      * destruct v1. destruct l; auto.
    + intros. exists v2. split.
      * apply add_3 with (x := x) (e' := (n, Secret)); auto.
      * destruct v2. destruct l; auto.
Qed.

Theorem add_indist :
  forall (x : string) (v1 v2 : nat_value) (st1 st2 : state),
    st1 == st2 ->
    v1 == v2 ->
    (add x v1 st1) == (add x v2 st2).
Proof.
  intros x v1 v2 st1 st2 Hstindist Hvindist.
  simpl "==". intros.
  destruct (String.eqb x x1) eqn:Heqx.
  - apply String.eqb_eq in Heqx.
    split.
    + intros. subst.
      apply MapsTo_eq with (v1 := v1) in H.
      * subst. exists v2. split.
        -- apply add_1. auto.
        -- destruct v0. destruct v2.
           destruct l; destruct l0;
             inversion Hvindist; auto.
      * apply add_1. auto.
    + intros. subst.
      apply MapsTo_eq with (v1 := v2) in H.
      * subst. exists v1. split.
        -- apply add_1. auto.
        -- destruct v1. destruct v3.
           destruct l; destruct l0;
             inversion Hvindist; auto.
      * apply add_1. auto.
  - apply String.eqb_neq in Heqx.
    split.
    + intros.
      apply add_3 with (x := x) (e' := v1) in H.
      simpl "==" in Hstindist.
      specialize (Hstindist x1 v0 v2).
      destruct Hstindist. destruct H0 as [v2']. assumption.
      destruct H0. exists v2'.
      split.
      * apply add_2 with
            (x := x)
            (e' := v2) in H0; assumption.
      * destruct v0. destruct v2'.
        destruct l; destruct l0;
          auto; exfalso; auto.
      * assumption.
    + intros.
      apply add_3 with (x := x) (e' := v2) in H.
      simpl "==" in Hstindist.
      specialize (Hstindist x1 v0 v3).
      destruct Hstindist.
      destruct H1 as [v1']. assumption.
      destruct H1.
      exists v1'. split.
      * apply add_2 with (x := x) (e' := v1) in H1;
          assumption.
      * destruct v1'. destruct v3.
        destruct l; destruct l0;
          auto; exfalso; auto.
      * assumption.
Qed.

Ltac secret_merge :=
  symmetry; apply secret_doms; simpl; auto.

Ltac open_indist H :=
  unfold "==" in H; simpl in H.

Lemma indist_f : forall (c1 c2 : com),
    com_indist_f c1 c2 ->
    c1 == c2.
Proof.
  intros. unfold "==". simpl. assumption.
Qed.

Theorem com_indist_refl : forall (c : com),
    c == c.
Proof.
  intros. induction c;
            unfold "=="; simpl; try tauto.
  - destruct l; auto.
Qed.

Theorem state_indist_refl : forall (st : state),
    st == st.
Proof.
  intros.
  simpl "==".
  intros.
  split; intros.
  - exists v1. split. auto.
    destruct v1. destruct l; auto.
  - exists v2. split. auto.
    destruct v2. destruct l; auto.
Qed.

Lemma ctxt_split : forall (st1 st2 : state) (l1 l2 : label),
    (st1, l1) == (st2, l2) ->
    st1 == st2 /\ l1 = l2.
Proof.
  intros.
  unfold "==" in *. simpl in *.
  destruct H. subst. split; auto.
Qed.

Theorem ctxt_indist_refl : forall (ctxt : sec_context),
    ctxt == ctxt.
Proof.
  intros. unfold "==". simpl.
  destruct ctxt. split.
  - reflexivity.
  - apply state_indist_refl.
Qed.

Lemma indist_neq_secret : forall {X} (x1 x2 : X) (l1 l2 : label),
    x1 <> x2 ->
    (x1, l1) == (x2, l2) ->
    l1 = l2 /\ l1 = Secret.
Proof.
  intros. unfold "==" in *. simpl in *.
  destruct l1; destruct l2;
    auto; exfalso; auto.
Qed.

Lemma indist_samelabel : forall {X} (x1 x2 : X) (l1 l2 : label),
    (x1, l1) == (x2, l2) ->
    l1 = l2.
Proof.
  intros.
  unfold "==" in H. simpl in H.
  destruct l1; destruct l2; subst;
    auto; exfalso; auto.
Qed.

Ltac simpl_indist :=
  unfold "=="; simpl; split; auto.

Theorem label_const : forall c (st st' : state) (l l' : label),
    (st, l) =[ c ]=> (st', l') ->
    l = l'.
Proof.
  intros c.
  induction c; intros.
  - inversion H. auto.
  - inversion H. subst. auto.
  - inversion H. subst.
    rename l' into l''.
    rename st' into st''.
    destruct ctxt' as [ st' l' ].
    assert (l = l').
    {
      apply IHc1 with (st := st) (st' := st').
      assumption.
    }
    subst.
    apply IHc2 with (st := st') (st' := st'').
    assumption.
  - inversion H; subst; auto.
Qed.

Theorem secret_step : forall (c : com) (st st': state),
    (st, Secret) =[ c ]=> (st', Secret) ->
    st == st'.
Proof.
  intros c.
  induction c; intros.
  - inversion H. subst. apply state_indist_refl.
  - inversion H. subst.
    replace (merge_list [l__v; l; Secret]) with Secret in *.
    + apply add_secret.
      replace (merge l__v Secret) with Secret in *.
      assumption.
      destruct l__v; auto.
    + symmetry. apply secret_doms. simpl. auto.
  - rename st' into st''.
    inversion H. subst.
    destruct ctxt' as [ st' l ].
    destruct l.
    + apply indist_trans with (st2 := st').
      * apply IHc1. assumption.
      * apply IHc2. assumption.
    + assert (Secret = Public).
      {
        apply (label_const c1 st st'). assumption.
      }
      congruence.
  - inversion H; subst;
      replace (merge Secret l__guard) with Secret in *;
      auto.
Qed.

Theorem leak_step : forall (c : com) (st st' : state),
    (st, Secret) =[ c ]=> (st', Public) -> False.
Proof.
  intros.
  generalize dependent st.
  generalize dependent st'.
  induction c; intros; inversion H.
  - inversion H. subst. destruct ctxt'.
    destruct l.
    + eapply IHc2. eauto.
    + eapply IHc1. eauto.
Qed.

Lemma indist_diff_label : forall (st1 st2 : state) (n1 n2 : nat)
                            (l1 l2 : label) (x : string),
    st1 == st2 ->
    l1 <> l2 ->
    MapsTo x (n1, l1) st1 ->
    MapsTo x (n2, l2) st2 ->
    False.
Proof.
  intros.
  simpl "==" in H.
  specialize (H x (n1, l1) (n2, l2)). destruct H.
  destruct H as [v2']. assumption.
  destruct H.
  replace v2' with (n2, l2) in *.
  - destruct l1; destruct l2;
      try tauto;
      try (exfalso; assumption).
  - apply MapsTo_eq with (st := st2) (x := x); assumption.
Qed.

Theorem aeval_diverges : forall (a : aexp) (st1 st2 : state)
                           (l1 l2 : label) (n1 n2 : nat),
    st1 == st2 ->
    n1 <> n2 ->
    aevalR st1 a (n1, l1) ->
    aevalR st2 a (n2, l2) ->
    l1 = Secret /\ l2 = Secret.
Proof.
  intros.
  destruct (label_eqb l1 l2) eqn:Heq.
  - apply label_eqb_eq in Heq.
    subst.
    assert ((n1, l2) == (n2, l2)).
    eapply aexp_EENI; eauto.
    simpl "==" in H3. destruct l2.
    + auto.
    + congruence.
  - apply label_eqb_neq in Heq.
    assert ((n1, l1) == (n2, l2)).
    eapply aexp_EENI; eauto.
    simpl "==" in H3.
    destruct l1; destruct l2;
      auto; exfalso; auto.
Qed.

Theorem beval_diverges : forall (b : bexp) (st1 st2 : state)
                           (l1 l2 : label) (b1 b2 : bool),
    st1 == st2 ->
    bevalR st1 b (b1, l1) ->
    bevalR st2 b (b2, l2) ->
    b1 <> b2 ->
    l1 = Secret /\ l2 = Secret.
Proof.
  intros.
  destruct (label_eqb l1 l2) eqn:Heq.
  - apply label_eqb_eq in Heq.
    subst.
    assert ((b1, l2) == (b2, l2)).
    eapply bexp_EENI; eauto.
    simpl "==" in H3. destruct l2.
    + auto.
    + congruence.
  - apply label_eqb_neq in Heq.
    assert ((b1, l1) == (b2, l2)).
    eapply bexp_EENI; eauto.
    simpl "==" in H3.
    destruct l2; destruct l1; auto; exfalso; auto.
Qed.

Ltac brute l1 l2 :=
  destruct l1; destruct l2;
  auto; exfalso; auto.

Theorem com_EENI :
  forall (c1 c2 : com)
    (ctxt1 ctxt2 ctxt1' ctxt2' : sec_context),
    c1 == c2 ->
    ctxt1 == ctxt2 ->
    ctxt1 =[ c1 ]=> ctxt1' ->
    ctxt2 =[ c2 ]=> ctxt2' ->
    ctxt1' == ctxt2'.
Proof.
  intros c1.
  induction c1; intros.
  - inversion H1. subst. unfold "==" in H. simpl in H.
    destruct c2 eqn:Hc2;
      try (exfalso; assumption).
    + subst. inversion H2. subst. assumption.
  - unfold "==" in H. simpl in H.
    destruct c2 eqn:Hc2;
      try (destruct l; exfalso; assumption).
    + subst.
      destruct l; destruct l0;
        try (exfalso; assumption).
      * inversion H1. subst. inversion H2. subst.
        replace (merge_list [l__v; Secret; l]) with Secret in *;
          try secret_merge.
        replace (merge_list [l__v0; Secret; l0]) with Secret in *;
          try secret_merge.
        -- inversion H0. subst.
           unfold "==". simpl. split.
           ++ reflexivity.
           ++ apply add_indist. assumption.
              apply secret_indist.
      * destruct H. subst. inversion H1. inversion H2. subst.
        inversion H0. subst.
        assert (l__v0 = l__v).
        {
          assert ((n, l__v) == (n0, l__v0)).
          apply aexp_EENI with
              (st1 := st)
              (st2 := st0)
              (a := a0); assumption.
          unfold "==" in H. simpl in H.
          destruct l__v; destruct l__v0; auto; exfalso; assumption.
        }
        subst.
        destruct l eqn:Hl.
        -- split. reflexivity.
           apply add_indist.
           assumption.
           destruct l__v; simpl; tauto.
        -- destruct l__v.
           ++ unfold "==". simpl. split. auto.
              apply add_indist. assumption.
              simpl. tauto.
           ++ unfold "==". simpl. split. auto.
              apply add_indist. assumption.
              simpl. assert ((n, Public) == (n0, Public)).
              apply aexp_EENI with
                  (st1 := st)
                  (st2 := st0)
                  (a := a0); assumption.
              unfold "==" in H. simpl in H. subst.
              auto.
  - open_indist H. destruct c2;
                     try (exfalso; assumption).
    + inversion H1. inversion H2. subst.
      assert (ctxt' == ctxt'0) as Hindist1.
      {
        apply IHc1_1 with
            (c2 := c2_1)
            (ctxt1 := ctxt1)
            (ctxt2 := ctxt2); try assumption.
        inversion H. unfold "==". simpl. assumption.
      }
      apply IHc1_2 with
          (c2 := c2_2)
          (ctxt1 := ctxt')
          (ctxt2 := ctxt'0); try assumption.
      inversion H. unfold "==". simpl. assumption.
  - (* Conditionals *)
    destruct c2; try inversion H.
    inversion H. subst.
    clear H5 H6. destruct H4.
    apply indist_f in H3.
    apply indist_f in H4.
    destruct ctxt1 as [ st1 l1 ].
    destruct ctxt2 as [ st2 l2 ].
    destruct ctxt1' as [ st1' l1' ].
    destruct ctxt2' as [ st2' l2' ].
    apply ctxt_split in H0. destruct H0. subst.
    inversion H1; inversion H2;
      destruct l2'; subst.
    + (* both eval to true, secret *)
      replace l__guard0 with l__guard in *.
      * replace (merge Secret l__guard) with Secret in *.
        -- apply IHc1_1 with
               (c2 := c2_1)
               (ctxt1 := (st1, Secret))
               (ctxt2 := (st2, Secret));
             try assumption. simpl_indist.
        -- auto.
      * apply indist_samelabel with
            (x1 := true) (x2 := true).
        apply bexp_EENI with (st1 := st1) (st2 := st2)
                             (b := b0);
          assumption.
    + (* both eval to true, public *)
      replace l__guard0 with l__guard in *.
      * eapply IHc1_1; eauto.
        simpl "==".
        split.
        -- destruct l__guard; auto.
        -- assumption.
      * assert ((true, l__guard) == (true, l__guard0)).
        eapply bexp_EENI; eauto.
        simpl "==" in H5.
        destruct l__guard; destruct l__guard0;
          auto; exfalso; auto.
    + assert (l__guard = Secret /\ l__guard0 = Secret).
      eapply beval_diverges; eauto.
      destruct H5. subst. simpl in H13. simpl in H22.
      apply secret_step in H13.
      apply secret_step in H22.
      clear H1. clear H2. clear H7. clear H16. clear H.
      clear H3. clear H4.
      assert (st1 == st2').
      {
        eapply indist_trans.
        apply H0. apply H22.
      }
      apply indist_comm in H13.
      assert (st1' == st2').
      {
        eapply indist_trans.
        apply H13. assumption.
      }
      simpl "==". split. auto. apply H1.
    + assert (l__guard = Secret /\ l__guard0 = Secret).
      eapply beval_diverges; eauto.
      destruct H5. subst.
      simpl in H13. simpl in H22.
      exfalso. eapply leak_step. apply H13.
    + assert (l__guard = Secret /\ l__guard0 = Secret).
      eapply beval_diverges; eauto.
      destruct H5. subst.
      simpl in H13. simpl in H22.
      clear H1. clear H2. clear H7. clear H16. clear H.
      clear H3. clear H4.
      apply secret_step in H13. apply secret_step in H22.
      assert (st1 == st2').
      {
        eapply indist_trans.
        apply H0. apply H22.
      }
      apply indist_comm in H13.
      assert (st1' == st2').
      {
        eapply indist_trans.
        apply H13. assumption.
      }
      simpl "==". split. auto. apply H1.
    + assert (l__guard = Secret /\ l__guard0 = Secret).
      eapply beval_diverges; eauto.
      destruct H5. subst.
      simpl in H13. simpl in H22.
      exfalso. eapply leak_step. apply H22.
    + replace (merge Secret l__guard) with Secret in *.
      replace (merge Secret l__guard0) with Secret in *.
      * eapply IHc1_2; eauto.
        simpl "==". split. auto. assumption.
      * destruct l__guard0; auto.
      * destruct l__guard; auto.
    + replace l__guard0 with l__guard in *.
      destruct l__guard.
      * simpl in H13. simpl in H22.
        apply secret_step in H13. apply secret_step in H22.
        assert (st1 == st2').
        eapply indist_trans.
        apply H0. apply H22.
        apply indist_comm in H13.
        assert (st1' == st2').
        eapply indist_trans.
        apply H13. assumption. simpl. split. auto.
        assumption.
      * simpl in H13. simpl in H22.
        assert ((st1, Public) == (st2, Public)).
        simpl. split. auto. assumption.
        eapply IHc1_2; eauto.
      * assert ((false, l__guard) == (false, l__guard0)).
        eapply bexp_EENI; eauto. simpl in H5.
        brute l__guard l__guard0.
Qed.


(*
  Verificación Formal - Unam 2020-2
  Ciro Iván García López
  Proyecto 1. Session Type Systems Verification
*)
From PROYI Require Import  Defs_Typing.
From PROYI Require Import  Defs_Process.
From PROYI Require Import  Defs_Proposition.
From Coq Require Import Strings.String.
From PROYI Require Import Props_Process.

(*
Lo siguientes lemas son intuitivamente ciertos, sin embargo su prueba
es difícil teniendo en cuenta que necesitan la idea que x aparece en P para que la operación  Close_Rec i x P tenga sentido.
*)
Lemma Close_Rec_Eq_Subst :
forall (P Q : Prepro)(x y : Name)( i: nat),
Process P -> Process Q ->
Close_Rec i x P = Close_Rec i y Q ->
P = {x\y} Q.
Proof.
Admitted.

Lemma Eq_Change_Var_Close :
forall (P : Prepro)(x y : Name),
Close x P = Close y ({y\x}P).
Admitted.

(*
*)
Lemma Char_Red_Arr :
forall (u x: Name)(P Q0 Q1 : Prepro),
( ((u !· Close x P) ↓ Q0) --> Q1 ) ->
(exists (Q2 : Prepro), ( Q1 = ((u !· Close x P) ↓ Q2) /\ Q0 --> Q2 )).
Proof.
  intros.
  inversion H; subst.
  + admit.
  + exists R.
    split; auto.
Admitted.

(*
Los siguientes lemas apoyan la prueba del teorema 2.1, determinan que algunos de los casos no se reducen a algo.
*)
Lemma No_Red_AX1 :
forall (x y : Name)(Q : Prepro),
~([x ←→  y] --> Q ).
Proof.
  unfold not.
  intros.
  inversion H.
Qed.

(*
*)
Lemma No_Red_AX2 :
forall (x y : Name)(P Q : Prepro),
~ ((x !· Close_Rec 0 y P) --> Q).
Proof.
  unfold not.
  intros.
  inversion H.
Qed.

(*
*)
Lemma No_Red_AX4 :
forall (x : Name)(P Q: Prepro),
~( (x · P) --> Q ).
Proof.
  unfold not.
  intros.
  inversion H.
Qed.

Check No_Red_AX4.

(*
*)
Lemma No_Red_AX51 :
forall (x y : Name)(P Q R: Prepro),
~( (x « y »· (P ↓ Q)) --> R ).
Proof.
  unfold not.
  intros.
  inversion H.
Qed.

(*
*)
Lemma No_Red_AX52 :
forall (x : Name)(P Q: Prepro),
(P = Q ) -> (Open_Rec 0 x P = Open_Rec 0 x Q).
Proof.
  intros.
  rewrite <- H.
  auto.
Qed.

(*
*)
Lemma No_Red_AX55 :
forall ( x y : Name),
Process_Name x -> Process_Name y -> (Open_Name 0 x (Close_Name 0 y y)) = x.
Proof.
  intros.
  inversion H; inversion H0; subst.
  specialize (string_dec x1 x1) as HX.
  destruct HX.
  + specialize (Str_True x1 x1) as HB.
    simpl.
    rewrite HB; auto.
  + contradiction.
Qed.

(*
*)
Lemma No_Red_AX5 :
forall (x y : Name)(P Q R: Prepro),
Process_Name x -> Process_Name y -> Process P -> Process Q ->
~( (ν Close_Rec 0 y (x « y »· (P ↓ Q))) --> R ).
Proof.
  unfold not.
  intros.
  inversion H3; subst.
  apply (No_Red_AX52 x0 _ _ ) in H4.
  unfold Close in H4.
  rewrite Eq_Subs_Close in H4; auto.
  simpl in H4.
  specialize (Close_Name_Output 0 y x) as HX.
  rewrite No_Red_AX55 in H4; auto.
  rewrite Eq_Subs_Close in H4; auto.
  rewrite Eq_Subs_Close in H4; auto.
  do 3 rewrite Ax_Alpha in H4.
  rewrite H4 in H8.
  destruct HX;
    try rewrite H9 in H8;
    try specialize (Open_PName_Output 0 x0 x) as HX || specialize (Open_BName_Output 0 x0) as HX;
    try rewrite HX in H8;
    try apply No_Red_AX51 in H8; auto.
Qed.

(*
*)
Lemma No_Red_AX6 :
forall (x : Name)(P Q : Prepro),
~( ( x ()· P ) --> Q).
Proof.
  unfold not.
  intros.
  inversion H.
Qed.

(*
*)
Lemma No_Red_AX71 :
forall ( x u : Name)( P Q : Prepro),
~((u « x »· P) --> Q).
Proof.
  unfold not.
  intros.
  inversion H.
Qed.

(*
Caso 7 no reduce a nada
*)
Lemma No_Red_AX7 :
forall ( x u : Name)( P Q : Prepro),
Process_Name x -> Process_Name u -> Process P ->
~(ν (Close_Rec 0 x (u « x »· P)) --> Q).
Proof.
  unfold not.
  intros.
  inversion H2; subst.
  apply (No_Red_AX52 x0 _ _ ) in H3.
  rewrite Eq_Subs_Close in H3; auto.
  rewrite Ax_Alpha in H3.
  simpl in H3.
  rewrite No_Red_AX55 in H3; auto.
  rewrite Eq_Subs_Close in H3; auto.
  rewrite Ax_Alpha in H3.
  rewrite H3 in H7.
  specialize (Close_Name_Output 0 x u) as HX.
  destruct HX;
    try rewrite H8 in H7;
    try specialize (Open_PName_Output 0 x0 u) as HX || specialize (Open_BName_Output 0 x0) as HX;
    try rewrite HX in H7;
    try apply No_Red_AX71 in H7;
    auto.
Qed.

(*
El caso 8 no reduce a nada
*)
Lemma No_Red_AX8 :
forall (x : Name)( Q : Prepro),
~ ((x «»·°) --> Q).
Proof.
  unfold not.
  intros.
  induction Q; try inversion H.
Qed.

(*
Construcción de un tipo de Proceso.
*)
Lemma Proc_Valid_V1 :
forall (P Q : Prepro)( u x : Name),
Process_Name u -> Process_Name x -> Process P -> Process Q ->
Process ((u !· Close x P) ↓ Q).
Proof.
  intros.
  constructor; auto.
  specialize ( Close_Is_Body x P) as HB.
  specialize ( HB H0 H1).
  inversion HB.
  constructor; auto.
Qed.

(*
Caracteriza la reducción de un proceso como el de la hipótesis.
*)
Lemma Char_Red_Chanres2 :
forall (P Q : Prepro)(x : Name),
Process P -> (ν (Close x P) --> Q ) ->
exists (Q0 : Prepro), ( Q = (ν (Close x Q0)) /\ P --> Q0).
Proof.
  intros.
  inversion H0; subst.
  exists ({x\x0}Q0).
  split.
  + specialize (Eq_Change_Var_Close Q0 x0 x) as HX.
    rewrite HX.
    auto.
  + specialize (Close_Rec_Eq_Subst P0 P x0 x 0) as HT.
    specialize (HT H2 H H1).
    rewrite Ax_Alpha in HT.
    rewrite Ax_Alpha.
    rewrite <- HT.
    auto.
Qed.

(*
Teorema 2.1 del artículo.
*)
Theorem Soundness :
forall (P : Prepro)(D F G : list Assignment),
  ( D ;;; F !- P ::: G ) -> (forall (Q: Prepro), (P --> Q)
  -> ( D ;;; F !- Q ::: G )).
Proof.
  intros P D F G H.
  induction H; intros.
  + apply No_Red_AX1 in H2. contradiction.
  + apply No_Red_AX1 in H2. contradiction.
  + apply No_Red_AX2 in H4. contradiction.
  + rewrite Ax_Alpha in H6.
    rewrite <- (Ax_Alpha u x Q).
    constructor; auto.
    apply (ProcessReduction_WD P Q); auto.
  + rewrite Ax_Alpha in H6.
    rewrite <- (Ax_Alpha u x Q).
    constructor; auto.
    apply (ProcessReduction_WD P Q); auto.
  + apply No_Red_AX2 in H4. contradiction.
  + apply No_Red_AX4 in H6. contradiction.
  + apply No_Red_AX5 in H10; try contradiction; auto.
  + apply No_Red_AX4 in H6. contradiction.
  + apply No_Red_AX5 in H10; try contradiction; auto.
  + apply No_Red_AX4 in H6. contradiction.
  + apply No_Red_AX5 in H10; try contradiction; auto.
  + apply No_Red_AX6 in H5. contradiction.
  + apply No_Red_AX8 in H1. contradiction.
  + apply No_Red_AX6 in H5. contradiction.
  + apply No_Red_AX8 in H1. contradiction.
  + apply No_Red_AX7 in H6; try contradiction; auto.
  + apply No_Red_AX7 in H6; try contradiction; auto.
  + specialize (Char_Red_Chanres2  ((u !· Close x P) ↓ Q) Q0 u) as HU.
    specialize (Proc_Valid_V1 P Q u x) as HV.
    specialize (HV H3 H2 H4 H5).
    specialize (HU HV H8).
    destruct HU as [Q1 H9].
    destruct H9.
    rewrite H9.
    specialize (Char_Red_Arr u x P Q Q1) as HT.
    specialize (HT H10).
    destruct HT as [Q2 H11].
    destruct H11.
    rewrite H11.
    apply (cutrep D F G x u P Q2 A); auto.
    apply (ProcessReduction_WD Q Q2); auto.
  + specialize (Char_Red_Chanres2  ((u !· Close x P) ↓ Q) Q0 u) as HU.
    specialize (Proc_Valid_V1 P Q u x) as HV.
    specialize (HV H3 H2 H4 H5).
    specialize (HU HV H8).
    destruct HU as [Q1 H9].
    destruct H9.
    rewrite H9.
    specialize (Char_Red_Arr u x P Q Q1) as HT.
    specialize (HT H10).
    destruct HT as [Q2 H11].
    destruct H11.
    rewrite H11.
    apply (cutcon D F G x u P Q2 A); auto.
    apply (ProcessReduction_WD Q Q2); auto.
Qed.


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

(**********************************************************************)
(*                   Substitution.v                                   *)
(*                                                                    *)
(*                     Barry Jay                                      *)
(*                                                                    *)
(* adapted from Substitution.v of Project Coq  to act on SF-terms     *)
(**********************************************************************)

Require Import Arith Omega List.
Require Import IntensionalLib.SF_calculus.Test.
Require Import IntensionalLib.SF_calculus.General.
Require Import IntensionalLib.SF_calculus.SF_Terms.
Require Import IntensionalLib.SF_calculus.SF_Tactics.
Require Import IntensionalLib.SF_calculus.SF_reduction.
Require Import IntensionalLib.SF_calculus.SF_Normal.
Require Import IntensionalLib.SF_calculus.SF_Closed.

(* Lifting *)

Definition relocate (i k n : nat) :=
  match test k i with
   (* k<=i *) | left _ => n+i
   (* k>i  *) | _ => i
  end.

Lemma relocate_null :
forall (n n0 : nat), relocate n n0 0 = n.
Proof. split_all. unfold relocate. case (test n0 n); intro; auto with arith. Qed.

Lemma relocate_lessthan : forall m n k, m<=k -> relocate k m n = (n+k).
Proof. split_all. unfold relocate. elim(test m k); split_all; try noway. Qed.
Lemma relocate_greaterthan : forall m n k, m>k -> relocate k m n = k.
Proof. split_all. unfold relocate. elim(test m k); split_all; try noway. Qed.

Ltac relocate_lt :=
try (rewrite relocate_lessthan; [| omega]; relocate_lt);
try (rewrite relocate_greaterthan; [| omega]; relocate_lt);
try(rewrite relocate_null).

Lemma relocate_zero_succ :
forall n k, relocate 0 (S n) k = 0.
Proof.  split_all. Qed.

Lemma relocate_succ :
forall n n0 k, relocate (S n) (S n0) k = S(relocate n n0 k).
Proof.
intros; unfold relocate. elim(test(S n0) (S n)); elim(test n0 n); split_all.
noway.
noway.
Qed.

Lemma relocate_mono : forall M N n k, relocate M n k = relocate N n k -> M=N.
Proof.
intros M N n k.
unfold relocate.
elim(test n M); elim(test n N); split_all; omega.
Qed.

Lemma relocate_null2 :
forall n k, relocate 0 (S n) k = 0.
Proof. split_all. Qed.

Fixpoint lift_rec (L : SF) : nat -> nat -> SF :=
  fun k n =>
  match L with
  | Ref i => Ref (relocate i k n)
  | Op o => Op o
  | App M N => App (lift_rec M k n) (lift_rec N k n)
   end.

Definition lift (n : nat) (N : SF) := lift_rec N 0 n.

(* Lifting lemmas *)

Lemma lift_rec_null_term :
forall (U : SF)(n: nat), lift_rec U n 0 = U.
Proof.
simple induction U; split_all.
relocate_lt; auto.
rewrite H; auto. rewrite H0; auto.
Qed.

Lemma lift1 :
 forall (U : SF) (j i k : nat),
 lift_rec (lift_rec U i j) (j + i) k = lift_rec U i (j + k).
Proof.
simple induction U; simpl in |- *;  split_all.
unfold relocate.
elim (test i n); elim (test (j+i) (j+ n)); split_all; try noway.
assert(k + (j + n) = j + k + n) by omega. congruence.
elim (test (j + i) n); split_all; try noway. rewrite H; auto. rewrite H0; auto.
Qed.

Lemma lift_lift_rec :
 forall (U : SF) (k p n i : nat),
 i <= n ->
 lift_rec (lift_rec U i p) (p + n) k = lift_rec (lift_rec U n k) i p.
Proof.
simple induction U; simpl in |- *;  split_all.
(* Ref *)
unfold relocate.
elim(test i n); split_all; try noway.
elim(test n0 n); split_all; try noway.
elim(test (p+n0) (p+n)); split_all; try noway.
elim(test i (k+n)); split_all; try noway.
assert(k+(p+n) = p+ (k+n)) by omega.
rewrite H0; auto.
elim(test (p+n0) (p+n)); split_all; try noway.
elim(test i n); split_all; try noway.
elim(test n0 n); split_all; try noway.
elim(test (p+n0) n); split_all; try noway.
elim(test i n); split_all; try noway.
(* Ap *)
rewrite H; split_all.  rewrite H0; split_all.
Qed.

Lemma lift_lift_term :
 forall (U : SF) (k p n : nat),
 lift_rec (lift p U) (p+ n) k = lift p (lift_rec U n k).
Proof.
unfold lift in |- *; intros; apply lift_lift_rec; trivial with arith.
Qed.

Lemma liftrecO : forall (U : SF) (n : nat), lift_rec U n 0 = U.
Proof.
simple induction U; simpl in |- *; intros; split_all; relocate_lt; congruence.
Qed.

Lemma liftO : forall (U : SF) , lift 0 U = U.
Proof.
unfold lift in |- *; split_all; apply liftrecO.
Qed.

Lemma lift_rec_lift_rec :
 forall (U : SF) (n p k i : nat),
 k <= i + n ->
 i <= k -> lift_rec (lift_rec U i n) k p = lift_rec U i (p + n).

Proof.
simple induction U; split_all.
(* Ref *)
unfold relocate.
elim(test i n); split_all; try noway.
elim(test k (n0 + n)); split_all; try noway.
replace (p+(n0+n)) with (p + n0 + n) by omega. auto.
elim(test k n); split_all; try noway.
(* Ap *)
rewrite H; split_all; rewrite H0; split_all; split_all.
Qed.

Lemma lift_rec_lift :
 forall (U : SF)  (n p k i : nat),
 k <= n -> lift_rec (lift  n U)  k p = lift (p + n) U.
Proof.
unfold lift in |- *; intros; rewrite lift_rec_lift_rec; trivial with arith.
Qed.

Lemma lift_rec_lift2 :
forall M n k, lift_rec (lift 1 M) (S n) k = lift 1 (lift_rec M n k).
Proof.
split_all.
unfold lift.
replace (S n) with (1+n) by omega.
rewrite lift_lift_rec; auto.
omega.
Qed.

Lemma lift_rec_app: forall M N n k, lift_rec (App M N) n k = App (lift_rec M n k) (lift_rec N n k).
Proof. split_all. Qed.
Lemma lift_rec_op: forall o n k, lift_rec (Op o) n k = Op o.
Proof. split_all. Qed.
Lemma lift_rec_ref: forall i n k, lift_rec (Ref i) n k = Ref (relocate i n k).
Proof. split_all. Qed.

Lemma lift_rec_not_ref_0 : forall M, lift_rec M 0 1 <> Ref 0.
Proof. induction M; split_all; try discriminate. case n; split_all; discriminate. Qed.

Lemma lift_rec_null :
forall (U : SF) (n: nat), lift_rec U n 0 = U.
Proof. simple induction U; split_all.
 rewrite relocate_null; congruence.
rewrite H; auto. rewrite H0; auto.
Qed.

Ltac  lift_tac :=
unfold_op; rewrite ? lift_rec_app; rewrite ? lift_rec_op; rewrite ? lift_rec_ref; relocate_lt;
rewrite ? lift_rec_not_ref_0.

Lemma lift_rec_preserves_compound :
forall (M: SF), compound M -> forall (n k : nat), compound(lift_rec M n k).
Proof.
intros M c; induction c; split_all.
Qed.
Hint Resolve lift_rec_preserves_compound.

Lemma lift_rec_preserves_status:
forall M n k, status (lift_rec M n k) = status M.
Proof.
match goal with
  | |- forall M, ?P  =>   cut (forall p M, p >= rank M -> P );
      [intros H M;  eapply2 H |
       intro p; induction p; intro M;  [ assert(rank M >0) by eapply2 rank_positive; noway |]
      ]
  end.

induction M; split_all.
rewrite IHM1. (* pepm 2: omega.  *)
gen_case H M1. gen_case H s. gen_case H s1. gen_case H o. eapply2 IHp; omega. omega.
Qed.

Lemma lift_rec_preserves_normal: forall M n k, normal M -> normal (lift_rec M n k).
Proof. induction M; intros. split_all. split_all.
inversion H. apply nf_active; fold lift_rec; auto.
replace  (App (lift_rec M1 n k) (lift_rec M2 n k))
with (lift_rec (App M1 M2) n k) by auto.
rewrite lift_rec_preserves_status. auto.
simpl. eapply2 nf_compound.
replace  (App (lift_rec M1 n k) (lift_rec M2 n k))
with (lift_rec (App M1 M2) n k) by auto.
eapply2 lift_rec_preserves_compound.
Qed.

Lemma lift_rec_closed: forall M n k, maxvar M = 0 -> lift_rec M n k = M.
Proof. induction M; split_all. omega. max_out. rewrite IHM1; auto;  rewrite IHM2; auto. Qed.

Lemma map_lift0 : forall Ms, map (lift 0) Ms = Ms.
Proof. induction Ms; split_all.   rewrite IHMs. unfold lift; rewrite lift_rec_null. auto. Qed.

Lemma lift_preserves_maxvar2:
  forall M, forall k, maxvar (lift k M) - k = maxvar M.
Proof.
  induction M; split_all. relocate_lt. induction k; split_all.
  rewrite max_minus. unfold lift in *; rewrite IHM1; rewrite IHM2; auto.
Qed.

Lemma lift_rec_reflects_compound : forall M n k, compound (lift_rec M n k) -> compound M.
Proof.
induction M; split_all; inversion H; subst; split_all.
gen_case H1 M1; try discriminate.  invsub.
gen_case H1 M1; try discriminate. inversion H1.
gen_case H2 s; try discriminate. subst; auto.
inversion H2; subst; auto.
gen_case H1 M1; try discriminate.  invsub.
gen_case H1 M1; try discriminate. inversion H1.
gen_case H2 s; try discriminate. subst; auto.
inversion H2; subst; auto.
Qed.

Lemma lift_rec_reflects_normal : forall M n k, normal (lift_rec M n k) -> normal M.
Proof.
induction M; split_all. inversion H; split_all.
replace (App (lift_rec M1 n k) (lift_rec M2 n k)) with (lift_rec (App M1 M2) n k) in H4 by auto.
rewrite lift_rec_preserves_status in *. eapply2 nf_active.
replace (App (lift_rec M1 n k) (lift_rec M2 n k)) with (lift_rec (App M1 M2) n k) in H4 by auto.
eapply2 nf_compound. eapply2 lift_rec_reflects_compound.
Qed.

(* Substitution *)

Definition insert_Ref (N : SF) (i k : nat) :=
  match compare k i with

   (* k<i *) | inleft (left _) => Ref (pred i)
   (* k=i *) | inleft _ => lift k N
   (* k>i *) | _ => Ref i
  end.

Fixpoint subst_rec (L : SF) : SF -> nat -> SF :=
  fun (N : SF) (k : nat) =>
  match L with
  | Ref i => insert_Ref N i k
  | Op o => Op o
  | App M M' => App (subst_rec M N k) (subst_rec M' N k)
  end.

Lemma subst_rec_op:
forall o N k, subst_rec (Op o) N k = Op o.
Proof.  split_all. Qed.

Lemma subst_rec_app:
forall M1 M2 N k, subst_rec (App M1 M2) N k = App (subst_rec M1 N k) (subst_rec M2 N k).
Proof.  split_all. Qed.

Lemma subst_rec_ref: forall i N k,  subst_rec (Ref i) N k = insert_Ref N i k.
Proof.  split_all. Qed.

Definition subst (M N : SF) := subst_rec M N 0.

(* The three cases of substitution of U for (Ref n) *)

Lemma subst_eq :
 forall (M U : SF) (n : nat), subst_rec (Ref n) U n = lift n U.
Proof.
simpl in |- *; unfold insert_Ref in |- *; split_all.
elim (compare n n); intro P; try noway.
elim P; intro Q; simpl in |- *; trivial with arith; try noway.
Qed.

Lemma subst_gt :
 forall (M U : SF) (n p : nat),
 n > p -> subst_rec (Ref n) U p = Ref (pred n).
Proof.
simpl in |- *; unfold insert_Ref in |- *.
intros; elim (compare p n); intro P.
elim P; intro Q; trivial with arith.
absurd (n > p); trivial with arith; rewrite Q; trivial with arith.
absurd (n > p); auto with arith.
Qed.

Lemma subst_lt :
 forall (M U : SF) (n p : nat), p > n -> subst_rec (Ref n) U p = Ref n.
Proof.
simpl in |- *; unfold insert_Ref in |- *.
intros; elim (compare p n); intro P; trivial with arith.
absurd (p > n); trivial with arith; elim P; intro Q; auto with arith.
rewrite Q; trivial with arith.
Qed.

(* Substitution lemma *)

Lemma lift_rec_subst_rec :
 forall (V U : SF) (k p n : nat),
 lift_rec (subst_rec V U p) (p + n) k =
 subst_rec (lift_rec V (S (p + n)) k) (lift_rec U n k) p.
Proof.
simple induction V; split_all.
(* 1 Ref *)
unfold insert_Ref, relocate in |- *.
elim (test (S(p + n0)) n); elim (compare p n); split_all.
elim a; elim(compare p (k+n)); split_all.
unfold relocate.
elim(test (p+n0) (pred n)); elim a1; split_all; try noway.
replace (k + pred n) with (pred (k + n)) by omega; auto.
noway.
noway.
noway.
noway.
elim a; split_all.
unfold relocate. elim(test(p+n0) (pred n)); split_all.
noway.
unfold lift.
rewrite lift_lift_rec; auto; omega.
unfold relocate.
elim(test (p+n0) n); split_all.
noway.
rewrite H; auto; rewrite H0; auto.
Qed.

Lemma lift_subst :
 forall (U V : SF) (k n : nat),
 lift_rec (subst U V) n k =
 subst (lift_rec U (S n) k) (lift_rec V n k).
Proof.
unfold subst in |- *; intros.
replace n with (0 + n).
rewrite lift_rec_subst_rec; trivial with arith.
auto.
Qed.

Lemma subst_rec_lift_rec1 :
 forall (U V : SF) (n p k : nat),
 k <= n ->
 subst_rec (lift_rec U k p) V (p + n) =
 lift_rec (subst_rec U V n) k p.
Proof.
simple induction U; intros; simpl in |- *; split_all.
(* Ref *)
unfold insert_Ref, relocate.
elim(test k n); split_all.
elim(compare n0 n); split_all; try noway.
elim a0; split_all; try noway.
elim(compare (p+n0) (p+n)); split_all.
elim a2; split_all; try noway.
unfold relocate.
elim(test k (pred n)); split_all; try noway.
assert(pred (p+n) = p + pred n) by omega. auto.
noway.
elim(compare (p+n0) (p+n)); split_all.
elim a1; split_all; try noway.
unfold lift. rewrite lift_rec_lift_rec; split_all; try omega.
unfold lift. rewrite lift_rec_lift_rec; split_all; try omega.
elim(compare (p+n0) (p+n)); split_all.
elim a0; split_all; try noway.
unfold relocate.
elim(test k n); split_all; try noway.
elim(compare (p+n0) n); split_all; try noway.
elim a; split_all; try noway.
elim(compare n0 n); split_all; try noway.
elim a; split_all; try noway.
unfold relocate.
elim(test k n); split_all; try noway.
(* 1 *)
rewrite H; split_all.  rewrite H0; split_all.
Qed.

Lemma subst_rec_lift1 :
 forall (U V : SF) (n p : nat),
 subst_rec (lift p U) V (p + n) = lift p (subst_rec U V n).
Proof.
unfold lift in |- *; intros; rewrite subst_rec_lift_rec1;
 trivial with arith.
Qed.

Lemma subst_rec_lift_rec :
 forall (U V : SF) (p q n : nat),
 q <= p + n ->
 n <= q -> subst_rec (lift_rec U n (S p)) V q = lift_rec U n p.
Proof.
simple induction U; intros; simpl in |- *; split_all.
unfold relocate. elim(test n0 n); split_all.
unfold insert_Ref.
elim(compare q (S(p+n))); split_all; try noway.
elim a0; split_all; try noway.
unfold insert_Ref.
elim(compare q n); split_all; try noway.
elim a; split_all; try noway.

(* 1 *)
rewrite H; split_all.
rewrite H0; auto.
Qed.

(* subst_rec_subst_rec *)

Lemma subst_rec_subst_rec :
 forall (V U W : SF) (n p : nat),
 subst_rec (subst_rec V U p) W (p + n) =
 subst_rec (subst_rec V W (S (p + n))) (subst_rec U W n) p.
Proof.
simple induction V;  split_all.

unfold insert_Ref in |- *.
elim (compare p n); split_all.
elim a; split_all.
elim (compare (S (p + n0)) n); split_all.
elim a1; split_all; try noway.
unfold insert_Ref.
elim (compare (p+n0) (pred n)); split_all; try noway.
elim a3; split_all; try noway.
elim (compare p (pred n)); split_all; try noway.
elim a5; split_all; try noway.
unfold lift; split_all.
unfold insert_Ref.
elim (compare (p+n0) (pred n)); split_all; try noway.
elim a2; split_all; try noway.
subst. unfold lift.
rewrite subst_rec_lift_rec; split_all; try omega.
unfold insert_Ref.
elim(compare (p+n0) (pred n)); split_all; try noway.
elim a1; split_all; try noway.
elim(compare p n); split_all; try noway.
elim a1; split_all; try noway.
elim (compare (S (p + n0)) n); split_all; try noway.
elim a0; split_all; try noway.
unfold insert_Ref.
elim(compare p n); split_all; try noway.
elim a0; split_all; try noway.
unfold lift.
subst.
rewrite subst_rec_lift_rec1; split_all.  omega.

unfold insert_Ref.
elim(compare (p+n0) n); split_all; try noway.
elim a; split_all; try noway.
elim(compare (S(p+n0)) n); split_all; try noway.
elim a; split_all; try noway.
unfold insert_Ref.
elim(compare p n); split_all; try noway.
elim a; split_all; try noway.
rewrite H; auto. rewrite H0; auto.
Qed.

Lemma subst_rec_subst_0 :
 forall (U V W : SF) (n : nat),
 subst_rec (subst_rec V U 0) W n =
 subst_rec (subst_rec V W (S n)) (subst_rec U W n) 0.
Proof.
intros; pattern n at 1 3 in |- *.
replace n with (0 + n) by trivial with arith.
rewrite (subst_rec_subst_rec V U W n 0); trivial with arith.
Qed.

(**************************)
(* The Substitution Lemma *)
(**************************)

Lemma substitution :
 forall (U V W : SF) (n : nat),
 subst_rec (subst U V) W n =
 subst (subst_rec U W (S n)) (subst_rec V W n).
Proof.
unfold subst in |- *; intros; apply subst_rec_subst_0; trivial with arith.
Qed.

(* to show (\ t)0 -> t  *)

Lemma subst_lift_null :
forall (W V : SF)(n : nat), subst_rec (lift_rec W n 1) V n = W.
Proof.
simple induction W; split_all.
unfold insert_Ref.
unfold relocate.
elim(test n0 n); split_all.
elim(compare n0 (S n)); split_all.
elim a0; split_all; noway.
noway.
elim(compare n0 n); split_all.
elim a; split_all. noway.
noway.
rewrite H; auto; rewrite H0; auto.
Qed.

(* more  Properties *)

Lemma subst_rec_lift2 :
forall M N n , subst_rec (lift 1 M) N (S n)  = lift 1 (subst_rec M N n).
Proof.
split_all.
unfold lift.
replace (S n) with (1+n) by omega.
rewrite subst_rec_lift_rec1; auto.
omega.
Qed.

Lemma insert_Ref_lt : forall M n k, n< k -> insert_Ref M n k = Ref n.
Proof.
induction M; unfold insert_Ref; split_all.
elim (compare k n0); split_all.
elim a; split_all; try noway.
elim (compare k n); split_all.
elim a; split_all; try noway.
elim (compare k n); split_all.
elim a; split_all; try noway.
Qed.

Lemma insert_Ref_eq : forall M n k, n= k -> insert_Ref M n k = lift k M.
Proof.
induction M; unfold insert_Ref; split_all.
elim (compare k n0); split_all.
elim a; split_all; try noway.
unfold lift; unfold lift_rec. unfold relocate. elim(test 0 n); split_all; try noway.
elim (compare k n); split_all.
elim a; split_all; try noway.
unfold lift; unfold lift_rec. unfold relocate. elim(test 0 n); split_all; try noway.
elim (compare k n); split_all.
elim a; split_all; try noway.
noway.
Qed.

Lemma insert_Ref_gt : forall M n k, n> k -> insert_Ref M n k = Ref (pred n).
Proof.
induction M; unfold insert_Ref; split_all.
elim (compare k n0); split_all.
elim a; split_all; try noway.
noway.
elim (compare k n); split_all.
elim a; split_all; try noway.
noway.
elim (compare k n); split_all.
elim a; split_all; try noway.
noway.
Qed.

Ltac insert_Ref_out :=
try (rewrite insert_Ref_lt; [|unfold relocate; split_all; omega]; insert_Ref_out);
try (rewrite insert_Ref_eq; [|unfold relocate; split_all; omega]; insert_Ref_out);
try (rewrite insert_Ref_gt; [|unfold relocate; split_all; omega]; insert_Ref_out).

Lemma fold_subst :  forall M1 M2 N, App (subst_rec M1 N 0) M2 = subst (App M1 (lift 1 M2)) N.
Proof.
  unfold subst, lift, subst_rec; split_all; fold subst_rec.
  rewrite subst_rec_lift_rec; try omega. rewrite lift_rec_null; auto.
Qed.

Ltac  subst_tac :=
unfold_op; unfold subst;
rewrite ? subst_rec_app; rewrite ? subst_rec_op; rewrite ? subst_rec_ref;
rewrite ? subst_rec_lift_rec; try omega; rewrite ? lift_rec_null;
unfold subst_rec; fold subst_rec; insert_Ref_out; unfold pred.

Definition subst_preserves_l (red: termred) :=
forall (M M' N : SF), red M M' -> red  (subst M N) (subst M' N).

Definition subst_preserves_r (red: termred) :=
forall (M N N' : SF), red N N' -> red  (subst M N) (subst M N').

Definition subst_preserves (red: termred) :=
forall (M M' : SF), red M M' -> forall N N', red N N' ->
red  (subst M N) (subst M' N').

Lemma subst_preserves_l_multi_step :
forall (red: termred), subst_preserves_l red -> subst_preserves_l (multi_step red).
Proof. unfold subst_preserves_l.
 induction 2; split_all.
apply succ_red with (subst N0 N); auto.
Qed.

Lemma subst_preserves_r_multi_step :
forall (red: termred), subst_preserves_r red -> subst_preserves_r (multi_step red).
Proof. unfold subst_preserves_r.
 induction 2; split_all.
apply succ_red with (subst M N); auto.
Qed.

Lemma subst_preserves_multi_step :
forall (red: termred), subst_preserves_l red -> subst_preserves_r red -> subst_preserves (multi_step red).
Proof.
unfold subst_preserves. split_all.
assert(transitive (multi_step red)) by eapply2 transitive_red.
unfold transitive in *.
apply X with  (subst M' N); auto.
eapply2 subst_preserves_l_multi_step.
eapply2 subst_preserves_r_multi_step.
Qed.

Lemma subst_preserves_compound:
forall (M: SF), compound M -> forall N, compound(subst M N).
Proof. intros M c; induction c; unfold subst; split_all. Qed.
Hint Resolve subst_preserves_compound.

Lemma  subst_rec_preserves_components_l : forall (M : SF) n k, compound M ->
  subst_rec(left_component M) n k = left_component(subst_rec M n k).
Proof. induction M; split_all; inv1 compound. Qed.

Lemma  subst_rec_preserves_components_r :
forall (M : SF),  compound M -> forall n k,
subst_rec(right_component M) n k = right_component(subst_rec M n k).
Proof. induction M; split_all; inversion H; subst; split_all. Qed.
Lemma subst_rec_preserves_compounds:
forall M N k, compound M -> compound (subst_rec M N k).
Proof. intros; inv1 compound. Qed.

Lemma subst_rec_preserves_left_component:
forall M N k, compound M ->
              subst_rec (left_component M) N k = left_component (subst_rec M N k) .
Proof. intros; inv1 compound. Qed.

Lemma subst_rec_preserves_right_component:
forall M N k, compound M ->
              subst_rec (right_component M) N k = right_component (subst_rec M N k) .
Proof. intros; inv1 compound. Qed.

Lemma subst_preserves_sf_red1 : subst_preserves sf_red1.
Proof.
red.
intros M M' R; induction R; unfold subst; split_all.
(* 11 *)
unfold insert_Ref. elim(compare 0 i); split_all. elim a; split_all.
unfold lift. repeat rewrite lift_rec_null_term; auto.
(* 10 *)
eapply2 app_sf_red.
(* 9 *)
eapply2 s_red.
(* 8 *)
eapply2 f_op_red.
(* 7 *)
assert(compound P') by eapply2 preserves_compound_sf_red1.
rewrite subst_rec_preserves_components_l; split_all.
rewrite subst_rec_preserves_components_r; split_all.
eapply2 f_compound_red.
eapply2 subst_preserves_compound.
Qed.

Lemma subst_preserves_sf_red : subst_preserves sf_red.
Proof. eapply2 subst_preserves_multi_step. red; split_all.
eapply2 subst_preserves_sf_red1. red; split_all.
eapply2 subst_preserves_sf_red1.
Qed.

Lemma subst_rec_closed: forall M N k, maxvar M <= k -> subst_rec M N k = M.
Proof.
induction M; split_all.
unfold insert_Ref. elim(compare k n); split_all. elim a; split_all. noway. noway.
assert (max (maxvar M1) (maxvar M2) >= maxvar M1) by eapply2 max_is_max.
assert (max (maxvar M1) (maxvar M2) >= maxvar M2) by eapply2 max_is_max.
rewrite IHM1; try omega;  rewrite IHM2; try omega. auto.
Qed.

Lemma subst_decreases_maxvar :
forall M N,  max (pred (maxvar M)) (maxvar N) >= maxvar(subst M N).
Proof.
unfold subst; induction M; split_all.
unfold insert_Ref.
case n; split_all. unfold lift. rewrite lift_rec_null_term. auto.
case (maxvar N); split_all.
assert(max n0 n1  >= n0) by eapply2 max_is_max.
omega.
omega.
(* 1 *)
rewrite max_pred.
assert(max (max (pred (maxvar M1)) (pred (maxvar M2))) (maxvar N) >=
max (pred (maxvar M1)) (maxvar N)).
eapply2 max_monotonic. eapply2 max_is_max.
assert(max (max (pred (maxvar M1)) (pred (maxvar M2))) (maxvar N) >=
max (pred (maxvar M2)) (maxvar N)).
eapply2 max_monotonic. eapply2 max_is_max.
assert(max (max (pred (maxvar M1)) (pred (maxvar M2))) (maxvar N) >=
max(max (pred (maxvar M1)) (maxvar N)) (max (pred (maxvar M2)) (maxvar N))).
eapply2 max_max2.
assert(max (max (pred (maxvar M1)) (maxvar N))
         (max (pred (maxvar M2)) (maxvar N))>=
max (maxvar (subst_rec M1 N 0)) (maxvar (subst_rec M2 N 0))).
eapply2 max_monotonic.
omega.
Qed.

Lemma subst_closed : forall M, maxvar M = 0 -> forall N, subst M N = M.
Proof.
induction M; split_all; subst. omega.
max_out. unfold subst in *; simpl. rewrite IHM1; try omega; rewrite IHM2; try omega; split_all.
Qed.

Ltac closed_tac M := repeat (rewrite (subst_rec_closed M); [| auto]);
                     repeat (rewrite (lift_rec_closed M); [| auto]).

Lemma fold_subst_list:
  forall sigma M N,  App (fold_left subst sigma M) N =
                     fold_left subst sigma (App M (lift (length sigma) N)).
Proof.
  induction sigma; split_all.
  (* 2 *)
  unfold lift; rewrite lift_rec_null. auto.
  (* 1 *)
  rewrite IHsigma. unfold subst. simpl. unfold lift. rewrite subst_rec_lift_rec; try omega. auto.
Qed.

Lemma list_subst_preserves_op:
  forall sigma o, fold_left subst sigma (Op o) = Op o.
  Proof. induction sigma; split_all. unfold subst in *. split_all. Qed.

Lemma list_subst_preserves_app:
  forall sigma M N, fold_left subst sigma (App M N) =
                    App (fold_left subst sigma M) (fold_left subst sigma N).
  Proof. induction sigma; split_all. unfold subst in *. split_all. Qed.

Lemma list_subst_preserves_sf_red:
  forall sigma M N, sf_red M N -> sf_red (fold_left subst sigma M) (fold_left subst sigma N).
Proof.  induction sigma; split_all. eapply2 IHsigma. eapply2 subst_preserves_sf_red. Qed.

Lemma list_subst_lift: forall sigma M, fold_left subst sigma (lift (length sigma) M) = M.
Proof.
  induction sigma; split_all. unfold lift; rewrite lift_rec_null. auto.
unfold lift, subst. rewrite subst_rec_lift_rec; try omega. unfold lift in *. rewrite IHsigma. auto.
Qed.


(**
This file is part of the Flocq formalization of floating-point
arithmetic in Coq: http://flocq.gforge.inria.fr/

Copyright (C) 2018-2019 Guillaume Bertholon
#
#
Copyright (C) 2018-2019 Érik Martin-Dorel
#
#
Copyright (C) 2018-2019 Pierre Roux

This library 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 3 of the License, or (at your option) any later version.

This library 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
COPYING file for more details.
*)

(** * Interface Flocq with Coq (>= 8.11) primitive floating-point numbers. *)

From Coq Require Import ZArith Reals Floats SpecFloat.
Require Import Zaux BinarySingleNaN.

(** Conversions from/to Flocq binary_float *)

Definition Prim2B (x : float) : binary_float prec emax :=
  SF2B (Prim2SF x) (Prim2SF_valid x).

Definition B2Prim (x : binary_float prec emax) : float :=
  SF2Prim (B2SF x).

Lemma B2Prim_Prim2B : forall x, B2Prim (Prim2B x) = x.
Proof.
intros x.
unfold Prim2B, B2Prim.
now rewrite B2SF_SF2B, SF2Prim_Prim2SF.
Qed.

Lemma Prim2B_B2Prim : forall x, Prim2B (B2Prim x) = x.
Proof.
intro x.
unfold Prim2B, B2Prim.
apply B2SF_inj.
rewrite B2SF_SF2B.
apply Prim2SF_SF2Prim.
apply valid_binary_B2SF.
Qed.

Lemma Prim2B_inj : forall x y, Prim2B x = Prim2B y -> x = y.
Proof.
intros x y Heq.
generalize (f_equal B2Prim Heq).
now rewrite 2!B2Prim_Prim2B.
Qed.

Lemma B2Prim_inj : forall x y, B2Prim x = B2Prim y -> x = y.
Proof.
intros x y Heq.
generalize (f_equal Prim2B Heq).
now rewrite 2!Prim2B_B2Prim.
Qed.

Lemma B2SF_Prim2B : forall x, B2SF (Prim2B x) = Prim2SF x.
Proof.
intros x.
apply SF2Prim_inj.
- rewrite SF2Prim_Prim2SF.
  apply B2Prim_Prim2B.
- apply valid_binary_B2SF.
- apply Prim2SF_valid.
Qed.

Lemma Prim2SF_B2Prim : forall x, Prim2SF (B2Prim x) = B2SF x.
Proof.
intro x; unfold B2Prim.
now rewrite Prim2SF_SF2Prim; [|apply valid_binary_B2SF].
Qed.

(** Basic properties of the Binary64 format *)

Local Instance Hprec : FLX.Prec_gt_0 prec := eq_refl _.

Local Instance Hmax : Prec_lt_emax prec emax := eq_refl _.

(** Equivalence between prim_float and Flocq binary_float operations *)

Theorem opp_equiv : forall x, Prim2B (- x) = Bopp (Prim2B x).
Proof.
intro x.
apply B2Prim_inj.
rewrite B2Prim_Prim2B.
apply Prim2SF_inj.
rewrite Prim2SF_B2Prim.
rewrite opp_spec.
rewrite <-B2SF_Prim2B.
now case Prim2B as [sx|sx| |sx mx ex Bx].
Qed.

Theorem abs_equiv : forall x, Prim2B (abs x) = Babs (Prim2B x).
Proof.
intro x.
apply B2Prim_inj.
rewrite B2Prim_Prim2B.
apply Prim2SF_inj.
rewrite Prim2SF_B2Prim.
rewrite abs_spec.
rewrite <-B2SF_Prim2B.
now case Prim2B as [sx|sx| |sx mx ex Bx].
Qed.

Theorem compare_equiv :
  forall x y,
  (x ?= y)%float = flatten_cmp_opt (Bcompare (Prim2B x) (Prim2B y)).
Proof.
intros x y.
rewrite compare_spec.
rewrite <-!B2SF_Prim2B.
now case (Prim2B x) as [sx|sx| |sx mx ex Bx];
  case (Prim2B y) as [sy|sy| |sy my ey By].
Qed.

Lemma round_nearest_even_equiv s m l :
  round_nearest_even m l = choice_mode mode_NE s m l.
Proof.
case l; [reflexivity|intro c].
case c; [|reflexivity..].
now simpl; unfold Round.cond_incr; case Z.even.
Qed.

Lemma binary_round_aux_equiv sx mx ex lx :
  SpecFloat.binary_round_aux prec emax sx mx ex lx
  = binary_round_aux prec emax mode_NE sx mx ex lx.
Proof.
unfold SpecFloat.binary_round_aux, binary_round_aux.
set (mrse' := shr_fexp _ _ _).
case mrse'; intros mrs' e'; simpl.
now rewrite (round_nearest_even_equiv sx).
Qed.

Theorem mul_equiv :
  forall x y,
  Prim2B (x * y) = Bmult mode_NE (Prim2B x) (Prim2B y).
Proof.
intros x y.
apply B2Prim_inj.
rewrite B2Prim_Prim2B.
apply Prim2SF_inj.
rewrite Prim2SF_B2Prim.
rewrite mul_spec.
rewrite <-!B2SF_Prim2B.
case (Prim2B x) as [sx|sx| |sx mx ex Bx];
  case (Prim2B y) as [sy|sy| |sy my ey By]; [now trivial..|].
simpl.
rewrite B2SF_SF2B.
apply binary_round_aux_equiv.
Qed.

Lemma binary_round_equiv s m e :
  SpecFloat.binary_round prec emax s m e =
  binary_round prec emax mode_NE s m e.
Proof.
unfold SpecFloat.binary_round, binary_round, shl_align_fexp.
set (mez := shl_align _ _ _); case mez as [mz ez].
apply binary_round_aux_equiv.
Qed.

Lemma binary_normalize_equiv m e szero :
  SpecFloat.binary_normalize prec emax m e szero
  = B2SF (binary_normalize prec emax Hprec Hmax mode_NE m e szero).
Proof.
case m as [|p|p].
- now simpl.
- simpl; rewrite B2SF_SF2B; apply binary_round_equiv.
- simpl; rewrite B2SF_SF2B; apply binary_round_equiv.
Qed.

Theorem add_equiv :
  forall x y,
  Prim2B (x + y) = Bplus mode_NE (Prim2B x) (Prim2B y).
Proof.
intros x y.
apply B2Prim_inj.
rewrite B2Prim_Prim2B.
apply Prim2SF_inj.
rewrite Prim2SF_B2Prim.
rewrite add_spec.
rewrite <-!B2SF_Prim2B.
case (Prim2B x) as [sx|sx| |sx mx ex Bx];
  case (Prim2B y) as [sy|sy| |sy my ey By];
  [now (trivial || simpl; case Bool.eqb)..|].
apply binary_normalize_equiv.
Qed.

Theorem sub_equiv :
  forall x y,
  Prim2B (x - y) = Bminus mode_NE (Prim2B x) (Prim2B y).
Proof.
intros x y.
apply B2Prim_inj.
rewrite B2Prim_Prim2B.
apply Prim2SF_inj.
rewrite Prim2SF_B2Prim.
rewrite sub_spec.
rewrite <-!B2SF_Prim2B.
case (Prim2B x) as [sx|sx| |sx mx ex Bx];
  case (Prim2B y) as [sy|sy| |sy my ey By];
  [now (trivial || simpl; case Bool.eqb)..|].
apply binary_normalize_equiv.
Qed.

Theorem div_equiv :
  forall x y,
  Prim2B (x / y) = Bdiv mode_NE (Prim2B x) (Prim2B y).
Proof.
intros x y.
apply B2Prim_inj.
rewrite B2Prim_Prim2B.
apply Prim2SF_inj.
rewrite Prim2SF_B2Prim.
rewrite div_spec.
rewrite <-!B2SF_Prim2B.
case (Prim2B x) as [sx|sx| |sx mx ex Bx];
  case (Prim2B y) as [sy|sy| |sy my ey By];
  [now (trivial || simpl; case Bool.eqb)..|].
simpl.
rewrite B2SF_SF2B.
set (melz := SFdiv_core_binary _ _ _ _ _ _).
case melz as [[mz ez] lz].
apply binary_round_aux_equiv.
Qed.

Theorem sqrt_equiv :
  forall x, Prim2B (sqrt x) = Bsqrt mode_NE (Prim2B x).
Proof.
intro x.
apply B2Prim_inj.
rewrite B2Prim_Prim2B.
apply Prim2SF_inj.
rewrite Prim2SF_B2Prim.
rewrite sqrt_spec.
rewrite <-B2SF_Prim2B.
case Prim2B as [sx|sx| |sx mx ex Bx]; [now (trivial || case sx)..|].
case sx; [reflexivity|].
simpl.
rewrite B2SF_SF2B.
set (melz := SFsqrt_core_binary _ _ _ _).
case melz as [[mz ez] lz].
apply binary_round_aux_equiv.
Qed.

Theorem normfr_mantissa_equiv :
  forall x,
  Int63.to_Z (normfr_mantissa x) = Z.of_N (Bnormfr_mantissa (Prim2B x)).
Proof.
intro x.
rewrite normfr_mantissa_spec.
rewrite <-B2SF_Prim2B.
now case Prim2B.
Qed.

Theorem ldexp_equiv :
  forall x e,
  Prim2B (ldexp x e) = Bldexp mode_NE (Prim2B x) e.
Proof.
intros x e.
apply B2Prim_inj.
rewrite B2Prim_Prim2B.
apply Prim2SF_inj.
rewrite Prim2SF_B2Prim.
rewrite ldexp_spec.
rewrite <-!B2SF_Prim2B.
case (Prim2B x) as [sx|sx| |sx mx ex Bx]; [now trivial..|].
simpl.
rewrite B2SF_SF2B.
apply binary_round_equiv.
Qed.

Theorem ldshiftexp_equiv :
  forall x e,
  Prim2B (ldshiftexp x e) = Bldexp mode_NE (Prim2B x) (Int63.to_Z e - shift).
Proof.
intros x e.
apply B2Prim_inj.
rewrite B2Prim_Prim2B.
apply Prim2SF_inj.
rewrite Prim2SF_B2Prim.
rewrite ldshiftexp_spec.
rewrite <-!B2SF_Prim2B.
case (Prim2B x) as [sx|sx| |sx mx ex Bx]; [now trivial..|].
simpl.
rewrite B2SF_SF2B.
apply binary_round_equiv.
Qed.

Theorem frexp_equiv :
  forall x : float,
  let (m, e) := frexp x in
  (Prim2B m, e) = Bfrexp (Prim2B x).
Proof.
intro x.
generalize (frexp_spec x).
destruct frexp as [f e].
rewrite <-(B2SF_Prim2B x).
replace (SFfrexp _ _ _)
  with (let (f, e) := Bfrexp (Prim2B x) in
        (B2SF f, e)).
- case Bfrexp; intros f' e' [= H ->]; f_equal.
  now apply B2SF_inj; rewrite B2SF_Prim2B.
- case (Prim2B x) as [s|s| |s m e' Hme] ; try easy.
  simpl.
  rewrite B2SF_SF2B.
  unfold Ffrexp_core_binary.
  change (digits2_pos m) with (Digits.digits2_pos m).
  now destruct Pos.leb.
Qed.

Theorem frshiftexp_equiv :
  forall x : float,
  let (m, e) := frshiftexp x in
  (Prim2B m, (Int63.to_Z e - shift)%Z) = Bfrexp (Prim2B x).
Proof.
intro x.
generalize (frexp_equiv x).
unfold frexp.
now case frshiftexp.
Qed.

Theorem infinity_equiv : infinity = B2Prim (B754_infinity false).
Proof. now compute. Qed.

Theorem neg_infinity_equiv : neg_infinity = B2Prim (B754_infinity true).
Proof. now compute. Qed.

Theorem nan_equiv : nan = B2Prim B754_nan.
Proof. now compute. Qed.

Theorem zero_equiv : zero = B2Prim (B754_zero false).
Proof. now compute. Qed.

Theorem neg_zero_equiv : neg_zero = B2Prim (B754_zero true).
Proof. now compute. Qed.

Theorem one_equiv : one = B2Prim Bone.
Proof. now compute. Qed.

Theorem two_equiv : two = B2Prim (Bplus mode_NE Bone Bone).
Proof. now compute. Qed.

Theorem ulp_equiv :
  forall x, Prim2B (ulp x) = Bulp' (Prim2B x).
Proof.
intro x.
unfold ulp, Bulp'.
rewrite one_equiv, ldexp_equiv, Prim2B_B2Prim.
generalize (frexp_equiv x).
case frexp; intros f e.
destruct Bfrexp as [f' e'].
now intros [= _ <-].
Qed.

Theorem next_up_equiv :
  forall x, Prim2B (next_up x) = Bsucc (Prim2B x).
Proof.
intro x.
apply B2Prim_inj.
rewrite B2Prim_Prim2B.
apply Prim2SF_inj.
rewrite Prim2SF_B2Prim.
rewrite next_up_spec.
rewrite <-B2SF_Prim2B.
assert (Hsndfrexp : forall x : binary_float prec emax, snd (SFfrexp prec emax (B2SF x)) = snd (Bfrexp x)).
{ intro x'.
  generalize (frexp_spec (B2Prim x')).
  generalize (frexp_equiv (B2Prim x')).
  case frexp; intros f' e'.
  rewrite Prim2B_B2Prim, Prim2SF_B2Prim.
  intros H H'; generalize (f_equal snd H'); generalize (f_equal snd H); simpl.
  now intros ->. }
assert (Hldexp : forall x e, SFldexp prec emax (B2SF x) e = B2SF (Bldexp mode_NE x e)).
{ intros x' e'.
  rewrite <-(Prim2B_B2Prim x'), B2SF_Prim2B, <-ldexp_spec.
  now rewrite <-B2SF_Prim2B, ldexp_equiv. }
assert (Hulp : forall x, SFulp prec emax (B2SF x) = B2SF (Bulp' x)).
{ intro x'.
  unfold SFulp, Bulp'.
  now rewrite Hsndfrexp, <-Hldexp. }
assert (Hpred_pos : forall x, (0 < B2R x)%R -> SFpred_pos prec emax (B2SF x) = B2SF (Bpred_pos' x)).
{ intros x' Fx'.
  unfold SFpred_pos, Bpred_pos'.
  rewrite Hsndfrexp.
  set (fe := fexp _ _ _).
  change (SFone _ _) with (B2SF Bone).
  rewrite Hldexp, Hulp.
  case x' as [sx|sx| |sx mx ex Bx]; try easy.
  unfold B2SF at 1.
  set (y := Bldexp _ _ _).
  set (z := Bulp' _).
  case Pos.eqb.
  - rewrite <-(Prim2B_B2Prim (B754_finite _ _ _ _)).
    rewrite <-(Prim2B_B2Prim y).
    now rewrite <-sub_equiv, !B2SF_Prim2B, sub_spec.
  - rewrite <-(Prim2B_B2Prim (B754_finite _ _ _ _)).
    rewrite <-(Prim2B_B2Prim z).
    now rewrite <-sub_equiv, !B2SF_Prim2B, sub_spec. }
case Prim2B as [sx|sx| |sx mx ex Bx]; [reflexivity|now case sx|reflexivity|].
rewrite <- Bsucc'_correct by easy.
unfold SF64succ, SFsucc, B2SF at 1, Bsucc'.
case sx.
- unfold B2SF at 1, SFopp at 2.
  rewrite <-(Prim2B_B2Prim (Bpred_pos' _)).
  rewrite <- opp_equiv, B2SF_Prim2B, opp_spec, Prim2SF_B2Prim.
  rewrite <- Hpred_pos.
  easy.
  now apply Float_prop.F2R_gt_0.
- rewrite Hulp.
  rewrite Bulp'_correct by easy.
  rewrite <-(Prim2B_B2Prim (B754_finite _ _ _ _)).
  rewrite <-(Prim2B_B2Prim (Bulp _)).
  rewrite <-add_equiv, !B2SF_Prim2B, add_spec, !Prim2SF_B2Prim.
  now unfold SF64add.
Qed.

Theorem next_down_equiv :
  forall x, Prim2B (next_down x) = Bpred (Prim2B x).
Proof.
intro x.
apply B2Prim_inj.
rewrite B2Prim_Prim2B.
apply Prim2SF_inj.
rewrite Prim2SF_B2Prim.
rewrite next_down_spec.
rewrite <-B2SF_Prim2B.
unfold Bpred.
rewrite <-(Prim2B_B2Prim (Bopp (Prim2B x))).
rewrite <-next_up_equiv, <-opp_equiv, !B2SF_Prim2B, opp_spec, next_up_spec.
unfold SF64pred, SFpred, SF64succ.
do 2 f_equal.
now rewrite <-opp_equiv, B2Prim_Prim2B, opp_spec.
Qed.

Theorem is_nan_equiv :
  forall x, PrimFloat.is_nan x = is_nan (Prim2B x).
Proof.
intro x.
unfold PrimFloat.is_nan.
rewrite eqb_spec.
rewrite <-B2SF_Prim2B.
case Prim2B as [sx|sx| |sx mx ex Bx]; [reflexivity|now case sx|reflexivity| ].
simpl.
rewrite Bool.negb_false_iff.
unfold SFeqb, SFcompare.
rewrite Z.compare_refl, Pos.compare_refl.
now case sx.
Qed.

Theorem is_zero_equiv :
  forall x,
  is_zero x = match Prim2B x with B754_zero _ => true | _ => false end.
Proof.
intro x.
unfold is_zero.
rewrite eqb_spec.
rewrite <-B2SF_Prim2B.
now case Prim2B as [sx|sx| |sx mx ex Bx]; try reflexivity; case sx.
Qed.

Theorem is_infinity_equiv :
  forall x,
  is_infinity x = match Prim2B x with B754_infinity _ => true | _ => false end.
Proof.
intro x.
unfold is_infinity.
rewrite eqb_spec.
rewrite <-B2SF_Prim2B.
rewrite B2SF_Prim2B, abs_spec.
rewrite <-B2SF_Prim2B.
now case Prim2B.
Qed.

Theorem get_sign_equiv : forall x, get_sign x = Bsign (Prim2B x).
Proof.
intro x.
unfold get_sign.
rewrite is_zero_equiv.
rewrite ltb_spec.
rewrite <-(B2Prim_Prim2B x).
case (Prim2B x) as [sx|sx| |sx mx ex Bx]; rewrite Prim2B_B2Prim.
- now rewrite div_spec; case sx.
- now case sx.
- now simpl.
- now rewrite Prim2SF_B2Prim; case sx.
Qed.

Theorem is_finite_equiv :
  forall x, PrimFloat.is_finite x = is_finite (Prim2B x).
Proof.
intro x.
unfold PrimFloat.is_finite.
rewrite is_nan_equiv, is_infinity_equiv.
now case (Prim2B x) as [sx|sx| |sx mx ex Bx].
Qed.

Theorem of_int63_equiv :
  forall i,
  Prim2B (of_int63 i)
  = binary_normalize prec emax Hprec Hmax mode_NE (Int63.to_Z i) 0 false.
Proof.
intro i.
apply B2SF_inj.
rewrite B2SF_Prim2B.
rewrite of_int63_spec.
apply binary_normalize_equiv.
Qed.

Theorem eqb_equiv :
  forall x y,
  (x == y)%float = Beqb (Prim2B x) (Prim2B y).
Proof.
intros x y.
rewrite eqb_spec.
unfold Beqb.
now rewrite !B2SF_Prim2B.
Qed.

Theorem ltb_equiv :
  forall x y,
  (x < y)%float = Bltb (Prim2B x) (Prim2B y).
Proof.
intros x y.
rewrite ltb_spec.
unfold Bltb.
now rewrite !B2SF_Prim2B.
Qed.

Theorem leb_equiv :
  forall x y,
  (x <= y)%float = Bleb (Prim2B x) (Prim2B y).
Proof.
intros x y.
rewrite leb_spec.
unfold Bleb.
now rewrite !B2SF_Prim2B.
Qed.


(** * Compilation of Imp to Asm *)

(** We are now ready to define our compiler.
    The compilation of [expr]essions is of little interest.
    The interesting part is in the structure of the
    compilation of instructions: we build higher level
    [asm] combinators from the primitive ones defined
    in [AsmCombinators.v]. Each of these combinator
    transcribes a control flow construct of the _Imp_
    language as a linking operation over _Asm_.
    Their correctness will be shown in the same style as
    the elementary combinators, isolating the control
    flow reasoning.
    Additionally, although naturally their choice here
    is tied to _Imp_, they are fairly generic constructs
    and could therefore be reused.
*)

(* begin hide *)
From ITreeTutorial Require Import Imp Asm Fin Utils_tutorial AsmCombinators.

From Coq Require Import
     Psatz
     List
     String
     Morphisms
     Setoid
     Decimal
     Numbers.DecimalString
     ZArith
     RelationClasses.

From ITree Require Import
     ITree.

Import ListNotations.
Open Scope string_scope.
(* end hide *)

(* ================================================================= *)
(** ** Compilation of expressions *)

Section compile_assign.

  (** Expressions are compiled straightforwardly.
      The argument [l] is the number of registers already introduced to compile
      the expression, and is used for the name of the next one.
      The result of the computation [compile_expr l e] always ends up stored in [l].
   *)
  Fixpoint compile_expr (l:reg) (e: expr): list instr :=
    match e with
    | Var x => [Iload l x]
    | Lit n => [Imov l (Oimm n)]
    | Plus e1 e2 =>
      let instrs1 := compile_expr l e1 in
      let instrs2 := compile_expr (1 + l) e2 in
      instrs1 ++ instrs2 ++ [Iadd l l (Oreg (1 + l))]
    | Minus e1 e2 =>
      let instrs1 := compile_expr l e1 in
      let instrs2 := compile_expr (1 + l) e2 in
      instrs1 ++ instrs2 ++ [Isub l l (Oreg (1 + l))]
    | Mult e1 e2 =>
      let instrs1 := compile_expr l e1 in
      let instrs2 := compile_expr (1 + l) e2 in
      instrs1 ++ instrs2 ++ [Imul l l (Oreg (1 + l))]
      end.

  (** Compiles the expression and then moves the result (in register [0]) to address
      [x].  Note: here we assume a one-to-one mapping of _Imp_ global variable names
      and _Asm_ addresses.
  *)
  Definition compile_assign (x: Imp.var) (e: expr): list instr :=
    let instrs := compile_expr 0 e in
    instrs ++ [Istore x (Oreg 0)].

End compile_assign.

(* ================================================================= *)
(** ** Control flow combinators *)

(** Sequencing of blocks: the program [seq_asm ab bc] links the
    exit points of [ab] with the entry points of [bc].

[[
           B
   A---ab-----bc---C
]]

   ... can be implemented using just [app_asm], [relabel_asm] and [loop_asm].

  Indeed, [app_asm ab bc] can be visualized as:
[[
  A---ab---B
  B---bc---C
]]
 i.e. a [asm (A + B) (B + C)]. To link them, we need first to swap the entry points.

We obtain the following diagram:
[seq_asm ab bc]
[[
       +------+
       |      |
   A------ab--+B
       |
      B+--bc------C
]]

Which translates to:
 *)
Definition seq_asm {A B C} (ab : asm A B) (bc : asm B C)
  : asm A C :=
  loop_asm (relabel_asm swap (id_ _) (app_asm ab bc)).

(** Location of temporary for [if]. *)
Definition tmp_if := 0.

(** Turns the list of instructions resulting from the conditional
    expression of a _if_ to a block with two exit points.
 *)
Definition cond_asm (e : list instr) : asm 1 2 :=
  raw_asm_block (after e (Bbrz tmp_if (fS f0) f0)).

(** Conditional branch of blocks.
    The program [if_asm e tp fp] creates a block out of [e] jumping
    either left or right.
    Using [seq_asm], this block is sequenced with the vertical
    composition [app_asm] of [tp] and [fp].
    Remains one mismatch: [app_asm] duplicates the domain of outputs,
    although they share the same. We hence use [relabel_asm] to collapse
    them together.

 [if_asm e tp fp]
[[
           true
       /ee-------tp---A\
    1--                 --A
       \ee-------fp---A/
           false
]]
 *)
Definition if_asm {A}
           (e : list instr) (tp : asm 1 A) (fp : asm 1 A) :
  asm 1 A :=
  seq_asm (cond_asm e)
          (relabel_asm (id_ _) merge (app_asm tp fp)).

(* Conditional looping of blocks.
   The program [while_asm e p] composes vertically two programs:
   an [if_asm] construct with [p] followed by a jump on the true branch,
   and a unique jump on the false branch.
   The loop is then closed with [loop_asm] by matching the jump from the
   true branch to the entry point.

[while_asm e p]
[[
      +-------------+
      |             |
      |    true     |
      |  e-------p--+
  1---+--e--------------1
           false
]]
*)
Definition while_asm (e : list instr) (p : asm 1 1) :
  asm 1 1 :=
  loop_asm (relabel_asm (id_ _) merge
    (app_asm (if_asm e
                (relabel_asm (id_ _) inl_ p)
                (pure_asm inr_))
            (pure_asm inl_))).

(** Equipped with our combinators, the compiler writes itself
    by induction on the structure of the statement.
*)
Fixpoint compile (s : stmt) {struct s} : asm 1 1 :=
  match s with
  | Skip       => id_asm
  | Assign x e => raw_asm_block (after (compile_assign x e) (Bjmp f0))
  | Seq l r    => seq_asm (compile l) (compile r)
  | If e l r   => if_asm (compile_expr 0 e) (compile l) (compile r)
  | While e b  => while_asm (compile_expr 0 e) (compile b)
  end.

(** We now consider its proof of correctness in [Imp2AsmCorrectness.v]. *)


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

 This tests the dynamic semantics of statements and expressions, pg. 58, 59.

*)

Set Implicit Arguments.
Require Export LanguageModuleDef.
Require Export DynamicSemanticsTypeSubstitution.
Require Export DynamicSemanticsHeapObjects.
Require Export DynamicSemantics.
Require Export Tacticals.

Require Export TestUtilities.

(* Test the S judgement. *)

(* ?TODO Let's make these tests more meaninful. *)

(* Let's make some e->e' transitions that actually evaluate something to test this stuff. *)

Definition s  := (if_s (i_e (i_i 0))
                       (e_s (i_e (i_i 0)))
                       (e_s (i_e (i_i 1)))).
Definition s' := (e_s (i_e (i_i 0))).

Definition e  := (dot (cpair (i_e (i_i 0)) (i_e (i_i 1))) zero_pe).
Definition e' := (i_e (i_i 0)).

Definition hxv := (H.ctxt x v hdot).

Example S_Let_3_1_test :
  S hdot (letx x v s) (H.ctxt x v hdot) s.
Proof.
  apply S_let_3_1;
  eauto 20 with Chapter3.
Qed.

Example S_seq_3_2_test :
  S hdot (seq (e_s v) s) hdot s.
Proof.
  apply S_seq_3_2.
  eauto 20 with Chapter3.
Qed.

Example S_return_3_3_test :
 S hdot (seq (retn v) s) hdot (retn v).
Proof.
  apply S_return_3_3.
  eauto 20 with Chapter3.
Qed.

Example S_if0_3_4_test :
 S hdot (if_s (i_e (i_i 0)) s1 s2)
   hdot s1.
Proof.
  apply S_if0_3_4.
Qed.

Example S_if_ne_0_3_5_test :
  S hdot (if_s vi1 s1 s2) hdot s2.
Proof.
  apply S_if_ne_0_3_5.
  eauto 20 with Chapter3.
Qed.

Example S_while_3_6_test :
 S hdot (while e s)
   hdot (if_s e (seq s (while e s)) (e_s (i_e (i_i 0)))).
Proof.
  apply S_while_3_6.
Qed.

(* Bug 8, just naming in two constructors. *)

(* TODO Questionable test? *)
Example S_open_3_7_test :
  S hdot (open (pack tau' v (etype aliases alpha k tau)) alpha x s)
    hdot (letx x' v (subst_St s tau alpha)).
Proof.
  apply S_open_3_7.
  eauto 20 with Chapter3.
Qed.

(* TODO Questionable test? *)
Definition etau := (etype aliases alpha A tau).
Definition H38 := (H.ctxt x (pack etau v etau) hdot).
Example pack_value:
  H.map H38 x = Some v' ->
  Value v'.
Proof.
  intros H.
  compute in H.
  compute.
  eauto 20 with Chapter3.
Qed.

(* Okay so H evaluates right and is a value. *)
(* Bug 20, State unbound. *)
(* Bug 21, Pack not in Values! *)
(* Is this a bug with get or is this just not syntax directed without
  some Tacticals. At least need Tactical for adding nil. *)
(* Bug 22, why is this not syntax directed ? Automation bug really. *)
Example S_openstar_3_8_test :
  S H38 (openstar (p_e x []) alpha x' s)
    H38 (letx x'  (amp (p_e x ([] ++ [u_pe])))
                          (subst_St s tau alpha)).
Proof.
  apply S_openstar_3_8 with
  (tau':= etau) (v:= v) (q:= aliases) (k:=A)
  (v':= (pack etau v etau));
  eauto 20 with Chapter3.
Qed.

Example S_exp_3_9_1_test :
  S hdot (e_s e) hdot (e_s e').
Proof.
  apply S_exp_3_9_1.
  eauto 20 with Chapter3.
Qed.

Example S_ret_3_9_2_test :
  S hdot (retn e) hdot (retn e').
Proof.
  apply S_ret_3_9_2.
  eauto 20 with Chapter3.
Qed.

Example S_if_3_9_3_test :
  S hdot (if_s e s1 s2) hdot (if_s e' s1 s2).
Proof.
  apply S_if_3_9_3.
  eauto 20 with Chapter3.
Qed.

Example S_letx_3_9_4_test :
  S hdot (letx x e s) hdot (letx x e' s).
Proof.
  apply S_letx_3_9_4.
  eauto 20 with Chapter3.
Qed.

(* ? TODO e not a value.*)
Example S_open_3_9_5_test :
  S hdot (open e alpha x s) hdot (open e' alpha x s).
Proof.
  apply S_open_3_9_5.
  eauto 20 with Chapter3.
Qed.

(* Bug 9 - extra tvar. *)
(* Bug 10. If returning the wrong clause. *)
Example S_seq_3_10_test :
  S hdot (seq s s2) hdot (seq s' s2).
Proof.
  apply S_seq_3_10.
  eauto 20 with Chapter3.
Qed.

Example S_openstar_3_11_test :
 S hdot (openstar (dot (p_e x []) zero_pe)    alpha x s)
   hdot (openstar      (p_e x [i_pe zero_pe]) alpha x s).
Proof.
  apply S_openstar_3_11.
  eauto 20 with Chapter3.
  apply L_xpi_3_1.
Qed.

(* Test R. *)

Definition h703 := (H.ctxt x v hdot).
Example R_get_3_1_test:
  R h703  (e_s (p_e x nil))
    h703  (e_s v).
Proof.
  (* I don't care because eauto can find this v'. *)
  apply R_get_3_1 with (v':=v);
  eauto 20 with Chapter3.
Qed.

Example R_assign_3_2_test:
  R (H.ctxt x (i_e (i_i 2)) hdot) (e_s (assign (p_e x []) (i_e (i_i 3))))
    (H.ctxt x (i_e (i_i 3)) hdot) (e_s (i_e (i_i 3))).
Proof.
 (* eauto 20 with Chapter3. works. *)
  eapply R_assign_3_2; try reflexivity;
  eauto 20 with Chapter3.
Qed.

Example R_initial_assign_3_2_test:
  R hdot (e_s (assign (p_e x []) (i_e (i_i 3))))
    (H.ctxt x (i_e (i_i 3)) hdot) (e_s (i_e (i_i 3))).
Proof.
 apply R_initial_assign_3_2;
 eauto 20 with Chapter3.
Qed.

Example R_star_3_3_test:
  R hxv (e_s (star (amp (p_e x nil))))
    hxv (e_s (p_e x nil)).
Proof.
  apply R_star_amp_3_3.
Qed.

Example R_dot_3_4_0_test:
  R hdot (e_s (dot (cpair v0 v1) zero_pe))
    hdot (e_s v0).
Proof.
  apply R_dot_3_4_0.
Qed.

Example R_dot_3_4_1_test:
  R hdot (e_s (dot (cpair v0 v1) one_pe))
    hdot (e_s v1).
Proof.
  apply R_dot_3_4_1.
Qed.

Example R_appl_3_5_test:
  R hdot (e_s (appl (f_e (dfun tau x tau' s)) v))
    hdot (e_s (call (letx x v s))).
Proof.
  apply R_appl_3_5.
  eauto 20 with Chapter3.
Qed.

Example R_call_3_6_test:
  R hdot (e_s (call (retn v)))
    hdot (e_s v).
Proof.
  apply R_call_3_6.
  eauto 20 with Chapter3.
Qed.

Example R_inst_3_7_test:
  R hdot (e_s (inst (f_e (ufun alpha k f)) tau))
    hdot (e_s (f_e (subst_F f tau alpha))).
Proof.
  apply R_inst_3_7.
Qed.

(* Bug 12, R instead of S in the precondition. *)

Example R_call_3_8_test:
  R hdot (e_s (call s)) hdot (e_s (call s')).
Proof.
  apply R_call_3_8.
  eauto 20 with Chapter3.
Qed.

(* Originally I had an invalid left expression here. *)

Example R_amp_3_9_1_test:
  R hxv (e_s (amp (dot (p_e x nil) zero_pe)))
    hxv (e_s (amp (p_e x [i_pe zero_pe]))).
Proof.
  apply R_amp_3_9_1.
  apply L_xpi_3_1.
Qed.

Example R_assign_3_9_2_test:
  R hdot (e_s (assign (star (amp (p_e x nil))) v0))
    hdot (e_s (assign (p_e x nil) v0)).
Proof.
  apply R_assign_3_9_2.
  eauto 20 with Chapter3.
Qed.

(* These would be nice for test but I can't make a statement into an expression. Even an If. *)

(* TODO It would be better if I went from h to h' here. *)
Example R_star_3_10_1_test:
  R hdot (e_s (star (star (amp (p_e x [])))))
    hdot (e_s (star (p_e x []))).
Proof.
  apply R_star_3_10_1.
  eauto 20 with Chapter3.
Qed.

Example R_dot_3_10_2_test:
  R hdot (e_s (dot (star (amp (p_e x [])))  zero_pe))
    hdot (e_s (dot (p_e x [])               zero_pe)).
Proof.
  apply R_dot_3_10_2.
  eauto 20 with Chapter3.
Qed.

(* TODO I should really make these change h to h' under e's evaluation. *)

Example Bug14_e_e':
 ~ R hdot (e_s (i_e (i_i 0)))
     hdot (e_s (i_e (i_i 1))).
Proof.
  compute.
  intros H.
  inversion H.
Qed.

(* Bug 17, L's instead of R's on precondition to 3.10 rules. *)
Example R_assign_3_10_3_test:
  R h (e_s (assign (p_e x pdot) e))
    h (e_s (assign (p_e x pdot) e')).
Proof.
  apply R_assign_3_10_3.
  eauto 20 with Chapter3.
Qed.

Example R_inst_3_10_4_test:
  R h  (e_s (inst e tau))
    h (e_s (inst e' tau)).
Proof.
  apply R_inst_3_10_4.
  eauto 20 with Chapter3.
Qed.

Example R_pack_3_10_5_test:
  R h  (e_s (pack tau' e  (etype witnesschanges alpha k tau)))
    h  (e_s (pack tau' e' (etype witnesschanges alpha k tau))).
Proof.
  apply R_pack_3_10_5.
  eauto 20 with Chapter3.
Qed.

(* Bug 18, Tau unquantified in three rules. *)
Example R_cpair_3_10_6_test:
  R h (e_s (cpair e e2))
    h (e_s (cpair e' e2)).
Proof.
  apply R_cpair_3_10_6.
  eauto 20 with Chapter3.
Qed.

Example R_cpair_3_10_7_test:
  R h (e_s (cpair v e))
    h (e_s (cpair v e')).
Proof.
  apply R_cpair_3_10_7;
  eauto 20 with Chapter3.
Qed.

Example R_cpair_3_10_8_test:
  R h (e_s (cpair e e2))
    h (e_s (cpair e' e2)).
Proof.
  apply R_cpair_3_10_8.
  eauto 20 with Chapter3.
Qed.

Example R_appl_3_10_9_test:
  R h (e_s (appl e e2))
    h (e_s (appl e' e2)).
Proof.
  apply R_appl_3_10_9.
  eauto 20 with Chapter3.
Qed.

Example R_appl_3_10_10_test:
  R h (e_s (appl v e))
    h (e_s (appl v e')).
Proof.
  apply R_appl_3_10_10;
  eauto 20 with Chapter3.
Qed.

(* Test L *)

Example L_xpi_3_1_test:
  L h (e_s (dot (p_e x nil) zero_pe))
    h (e_s (p_e x [(i_pe zero_pe)])).
Proof.
 apply L_xpi_3_1.
Qed.

Example L_staramp_3_2_test:
  L h (e_s (star (amp (p_e x nil)))) h (e_s (p_e x nil)).
Proof.
 apply L_staramp_3_2.
Qed.

(* Bug 11, h should have been h'. *)
(* Bug 14, extra e in quantification. *)
Example L_star_3_3_test:
  L h (e_s (star e)) h (e_s (star e')) .
Proof.
 eapply L_star_3_3.
 eauto 20 with Chapter3.
Qed.

(* Bug 19, extra quantified variable. *)
Example L_ei_3_4_test:
  L hdot (e_s (dot (dot (p_e x []) zero_pe) zero_pe))
    hdot (e_s (dot (p_e x ([] ++ [i_pe zero_pe])) zero_pe)).
Proof.
 apply L_ei_3_4.
 eauto 20 with Chapter3.
Qed.