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.
From Coq Require Import Array.PArray.

Require Import Uint63.

Import ListNotations.

Definition total_map (A : Type) := string -> A.

Definition t_empty {A : Type} (v : A) : total_map A :=
  (fun _ => v).

Definition eqb_string (x y : string) : bool :=
  if string_dec x y then true else false.

Definition t_update {A : Type} (m : total_map A)
                    (x : string) (v : A) :=
  fun x' => if eqb_string x x' then v else m x'.

Notation "'_' '!->' v" := (t_empty v)
  (at level 100, right associativity).

Notation "x '!->' v ';' m" := (t_update m x v)
                              (at level 100, v at next level, right associativity).

Theorem eqb_string_refl : forall s : string, true = eqb_string s s.
Proof.
  intros s. unfold eqb_string.
  destruct (string_dec s s) as [Hs_eq | Hs_not_eq].
  - reflexivity.
  - destruct Hs_not_eq. reflexivity.
Qed.

Lemma t_update_eq : forall (A : Type) (m : total_map A) x v,
    (x !-> v ; m) x = v.
Proof.
  intros. unfold t_update.  rewrite <- eqb_string_refl.
  reflexivity.
Qed.

Definition state := total_map nat.

Inductive aexp : Type :=
  | ANum (n : nat)
  | AVars (x : string) (* Var *)
  | ACH (x : string) (* Cache *)
  | APlus (a1 a2 : aexp)
  | AMinus (a1 a2 : aexp)
  | AMult (a1 a2 : aexp)
  | ADiv (a1 a2 : aexp).

Inductive bexp : Type :=
  | BTrue
  | BFalse
  | BEq (a1 a2 : aexp)
  | BLe (a1 a2 : aexp)
  | BNot (b : bexp)
  | BAnd (b1 b2 : bexp).

Definition W : string := "W".
Definition X : string := "X".
Definition Y : string := "Y".
Definition Z : string := "Z".
Definition F : string := "0x21d36e0".
Definition M1 : string := "M1".
Definition M2 : string := "M2".
Definition M : string := "M".

Definition Error : string := "Error".

Definition I : string := "instance".
Definition H : string := "host".

Coercion AVars : string >-> aexp.

Coercion ANum : nat >-> aexp.

Definition bool_to_bexp (b : bool) : bexp :=
  if b then BTrue else BFalse.
Coercion bool_to_bexp : bool >-> bexp.

Notation "x + y" := (APlus x y) (at level 50, left associativity).
Notation "x - y" := (AMinus x y) (at level 50, left associativity).
Notation "x * y" := (AMult x y) (at level 40, left associativity).
Notation "x / y" := (ADiv x y) (at level 40, left associativity).
Notation "x <= y" := (BLe x y) (at level 70, no associativity).
Notation "x = y" := (BEq x y) (at level 70, no associativity).
Notation "x && y" := (BAnd x y) (at level 40, left associativity).
Notation "'~' b" := (BNot b) (at level 75, right associativity).

Fixpoint acal (st_v : state) (st_c : state) (a : aexp) : nat :=
  match a with
  | ANum n => n
  | AVars x => if (prefix "0x" x) then st_c x else st_v x
  | ACH x => if (prefix "0x" x) then st_c x else st_v x
  | APlus a1 a2 => (acal st_v st_c a1) + (acal st_v st_c a2)
  | AMinus a1 a2  => (acal st_v st_c a1) - (acal st_v st_c a2)
  | AMult a1 a2 => (acal st_v st_c a1) * (acal st_v st_c a2)
  | ADiv a1 a2 => (acal st_v st_c a1) / (acal st_v st_c a2)
  end.

Fixpoint bcal (st_v : state) (st_c : state) (b : bexp) : bool :=
  match b with
  | BTrue       => true
  | BFalse      => false
  | BEq a1 a2   => (acal st_v st_c a1) =? (acal st_v st_c a2)
  | BLe a1 a2   => (acal st_v st_c a1) <=? (acal st_v st_c a2)
  | BNot b1     => negb (bcal st_v st_c b1)
  | BAnd b1 b2  => andb (bcal st_v st_c b1) (bcal st_v st_c b2)
  end.

Definition empty_st := (_ !-> 0).

Definition clear_cache (st: state) : state :=
  match st with
  | _ => empty_st
 end.

Notation "x '!->' v" := (t_update empty_st x v) (at level 100).

Inductive channel : Set :=
| CH : nat -> channel.

Inductive act : Type :=
  | CSkip
  | CStop
  | CSleep (t : int)
  | CAss (x : string) (a : aexp)
  | CSeq (c1 c2 : act)
  | CIf (b : bexp) (c1 c2 : act)
  | CWhile (b : bexp) (c : act)
  | CSend (ch : channel) (ad : string) (a : aexp)
  | CRecv (ch : channel) (ad x : string)
  | CMovep (i i' : string)
  | CMovei (h i h' i' : string)
  | CPar (c1 c2 : act).

Notation "'SKIP'" :=
   CSkip.
Notation "'STOP'" :=
   CStop.
Notation "'SLEEP' t" :=
  (CSleep t) (at level 60).
Notation "x '::=' a" :=
  (CAss x a) (at level 60).
Notation "c1 ;; c2" :=
  (CSeq c1 c2) (at level 65, right associativity).
Notation "'WHILE' b 'DO' c 'END'" :=
  (CWhile b c) (at level 80, right associativity).
Notation "'IFB' b 'THEN' c1 'ELSE' c2 'END'" :=
  (CIf b c1 c2) (at level 80, right associativity).
Notation "ch '#' ad '!' a" :=
  (CSend ch ad a) (at level 80, right associativity).
Notation "ch '#' ad '?' x" :=
  (CRecv ch ad x) (at level 80, right associativity).
Notation "'MOVEp' ( i ) 'to' ( i' )" :=
  (CMovep i i') (at level 80, right associativity).
Notation "'MOVEi' ( h ) ( i ) 'to' ( h' ) ( i' )" :=
  (CMovei h i h' i') (at level 80, right associativity).
Notation "c1 '//' c2" :=
  (CPar c1 c2) (at level 70, right associativity).

Inductive ty : Type :=
  | Low : ty
  | High : ty
  | Medium : ty
  | None : ty.

Inductive ins_ty : Type :=
  | ins_none : ins_ty
  | ins_0 : ins_ty
  | ins_1 : ins_ty
  | ins_2 : ins_ty.

Inductive hos_ty : Type :=
  | hos_none : hos_ty
  | hos_0 : hos_ty
  | hos_1 : hos_ty
  | hos_2 : hos_ty.

Definition vc_level := total_map ty.
Definition i_level := total_map ins_ty.
Definition h_level := total_map hos_ty.
Definition c_ins := total_map string.

Definition t_update_ty (m : total_map ty)
                    (x : string) (v : ty) :=
  fun x' => if eqb_string x x' then v else m x'.

Definition t_update_ins_ty (m : total_map ins_ty)
                    (x : string) (v : ins_ty) :=
  fun x' => if eqb_string x x' then v else m x'.

Definition t_update_hos_ty (m : total_map hos_ty)
                    (x : string) (v : hos_ty) :=
  fun x' => if eqb_string x x' then v else m x'.

Definition t_update_c_ins (m : total_map string)
                    (x : string) (v : string) :=
  fun x' => if eqb_string x x' then v else m x'.

Definition empty_ty := (_ !-> None).
Definition empty_ins_ty := (_ !-> ins_none).
Definition empty_host_ty := (_ !-> hos_none).
Definition empty_c_i := (_ !-> "NoInstance"%string).
Notation "x '|->' v" := (t_update_ty empty_ty x v) (at level 100).
Notation "x '|i|->' v" := (t_update_ins_ty empty_ins_ty x v) (at level 100).
Notation "x '|h|->' v" := (t_update_hos_ty empty_host_ty x v) (at level 100).
Notation "x '|=>' v" := (t_update_c_ins empty_c_i x v) (at level 100).

Notation "x '|->' v ';' m" := (t_update_ty m x v)
                              (at level 100, v at next level, right associativity).
Notation "x '|i|->' v ';' m" := (t_update_ins_ty m x v)
                              (at level 100, v at next level, right associativity).
Notation "x '|h|->' v ';' m" := (t_update_hos_ty m x v)
                              (at level 100, v at next level, right associativity).
Notation "x '|=>' v ';' m" := (t_update_c_ins m x v)
                              (at level 100, v at next level, right associativity).

Inductive env : Type :=
  | Env (v_ty c_ty : vc_level)(v_l c_l : list string)(c_i : c_ins)
        (i_ty : i_level)(h_ty : h_level)(i_l h_l : list string)(st_v st_c: state).

Inductive jud : Type :=
  | Jud (tau : vc_level)(omegaI : i_level)(omegaH : h_level).

Definition get_st_v (ev : env) : state :=
  match ev with
  | Env v_ty c_ty v_l c_l c_i i_ty h_ty i_l h_l st_v st_c => st_v
  end.

Definition get_st_c (ev : env) : state :=
  match ev with
  | Env v_ty c_ty v_l c_l c_i i_ty h_ty i_l h_l st_v st_c => st_c
  end.

Definition get_v_ty (ev : env) : vc_level :=
  match ev with
  | Env v_ty c_ty v_l c_l c_i i_ty h_ty i_l h_l st_v st_c => v_ty
  end.

Definition get_c_ty (ev : env) : vc_level :=
  match ev with
  | Env v_ty c_ty v_l c_l c_i i_ty h_ty i_l h_l st_v st_c => c_ty
  end.

Definition get_c_i (ev : env) : c_ins :=
  match ev with
  | Env v_ty c_ty v_l c_l c_i i_ty h_ty i_l h_l st_v st_c => c_i
  end.

Definition get_v_l (ev : env) : list string :=
  match ev with
  | Env v_ty c_ty v_l c_l c_i i_ty h_ty i_l h_l st_v st_c => v_l
  end.

Definition get_i_l (ev : env) : list string :=
  match ev with
  | Env v_ty c_ty v_l c_l c_i i_ty h_ty i_l h_l st_v st_c => i_l
  end.

Definition get_h_l (ev : env) : list string :=
  match ev with
  | Env v_ty c_ty v_l c_l c_i i_ty h_ty i_l h_l st_v st_c => h_l
  end.

Definition get_c_l (ev : env) : list string :=
  match ev with
  | Env v_ty c_ty v_l c_l c_i i_ty h_ty i_l h_l st_v st_c => c_l
  end.

Definition get_i_ty (ev : env) : i_level :=
  match ev with
  | Env v_ty c_ty v_l c_l c_i i_ty h_ty i_l h_l st_v st_c => i_ty
  end.

Definition get_h_ty (ev : env) : h_level :=
  match ev with
  | Env v_ty c_ty v_l c_l c_i i_ty h_ty i_l h_l st_v st_c => h_ty
  end.

Definition get_tau (ju : jud) : vc_level :=
  match ju with
  | Jud tau omegaI omegaH => tau
  end.

Definition get_omegaI (ju : jud) : i_level :=
  match ju with
  | Jud tau omegaI omegaH => omegaI
  end.

Definition get_omegaH (ju : jud) : h_level :=
  match ju with
  | Jud tau omegaI omegaH => omegaH
  end.

Definition get_high_level (a b : ty) : ty :=
   match a with
      | High => High
      | Medium => match b with
                | High => High
                | _ => Medium
                end
      | _ => match b with
                | High => High
                | Medium => Medium
                | _ => Low
                end
end.

Fixpoint atype (a : aexp) (v_ty c_ty : vc_level) : ty :=
  match a with
  | ANum n => Low
  | AVars x | ACH x => match v_ty x with
               | None => match c_ty x with
                         | None => Low
                         | _ => c_ty x
                         end
               | _ => v_ty x
               end
  | APlus a1 a2 | AMinus a1 a2 | AMult a1 a2 | ADiv a1 a2
    => get_high_level (atype a1 v_ty c_ty) (atype a2 v_ty c_ty)
  end.

Fixpoint btype (b : bexp) (v_ty c_ty : vc_level) : ty :=
  match b with
  | BTrue | BFalse     => Low
  | BEq a1 a2 | BLe a1 a2
   => get_high_level (atype a1 v_ty c_ty) (atype a2 v_ty c_ty)
  | BNot b1     => btype b1 v_ty c_ty
  | BAnd b1 b2  => get_high_level (btype b1 v_ty c_ty) (btype b2 v_ty c_ty)
  end.

Definition update_type_sub (lv v_ty c_ty tau: vc_level) (c : act) : vc_level :=
   match c with
   | x ::= a => match lv x with
                | High => lv
                | Medium => match tau x with
                        | High => x |-> High; lv
                        | _ => match atype a v_ty c_ty with
                              | High => x |-> High; lv
                              | _ => lv
                              end
                         end
                | Low => match tau x with
                        | High => x |-> High; lv
                        | Medium => match atype a v_ty c_ty with
                              | High => x |-> High; lv
                              | _ => x |-> Medium; lv
                              end
                        | _ => match atype a v_ty c_ty with
                              | High => x |-> High; lv
                              | Medium => x |-> Medium; lv
                              | _ => lv
                              end
                         end
                | _ => match tau x with
                        | High => x |-> High; lv
                        | Medium => match atype a v_ty c_ty with
                              | High => x |-> High; lv
                              | _ => x |-> Medium; lv
                              end
                        | _ => match atype a v_ty c_ty with
                              | High => x |-> High; lv
                              | Medium => x |-> Medium; lv
                              | _ => x |-> Low; lv
                              end
                         end
               end
   | _ => lv
  end.

Definition update_type' (v_ty c_ty tau: vc_level) (c : act) : vc_level :=
  match c with
   | x ::= a =>  match prefix "0x" x with
               | true => update_type_sub c_ty v_ty c_ty tau c
               | false => update_type_sub v_ty v_ty c_ty tau c
               end
   | a#c_ad! w => match tau c_ad with
                | High => match c_ty c_ad with
                        | High => c_ty
                        | _ => c_ad |-> High; c_ty
                         end
                | _ => match c_ty c_ad with
                        | High => c_ty
                        | Medium => match atype w v_ty c_ty with
                                 | High => c_ad |-> High; c_ty
                                 | _ => c_ty
                                 end
                        | _ =>  match atype w v_ty c_ty with
                                 | High => c_ad |-> High; c_ty
                                 | Medium => c_ad |-> Medium; c_ty
                                 | _ => match c_ty c_ad with
                                        | Low => match tau c_ad with
                                                 | Medium => c_ad |-> Medium; c_ty
                                                 | _ => c_ty
                                                 end
                                        | _ => match tau c_ad with
                                                 | Medium => c_ad |-> Medium; c_ty
                                                 | _ => c_ad |-> Low; c_ty
                                                 end
                                        end
                                 end
                        end
               end
   | a#c_ad? x => match tau x with
                | High => match v_ty x with
                        | High => v_ty
                        | _ => x |-> High; v_ty
                        end
                | _ => match v_ty x with
                        | High => v_ty
                        | Medium => match c_ty c_ad with
                                 | High => x |-> High; v_ty
                                 | _ => v_ty
                                 end
                        | _ => match c_ty c_ad with
                                 | High => x |-> High; v_ty
                                 | Medium => x |-> Medium; v_ty
                                 | _ => match v_ty x with
                                        | Low => match tau x with
                                                 | Medium => x |-> Medium; v_ty
                                                 | _ => v_ty
                                                 end
                                        | _ => match tau x with
                                                 | Medium => x |-> Medium; v_ty
                                                 | _ => x |-> Low; v_ty
                                                 end
                                        end
                                 end
                        end
               end
   | _ => empty_ty
  end.

Definition update_type (ev : env) (ju : jud) (c : act) : vc_level :=
  update_type'(get_v_ty ev) (get_c_ty ev) (get_tau ju) c.

Fixpoint In (a:string) (l:list string) : bool :=
    match l with
      | [] => false
      | b :: m => if (eqb_string a b) then true else (In a m)
    end.

Definition update_v_l' (v_l: list string) (c : act): list string :=
  match c with
   | x ::= a => if (In x v_l) then v_l else x::v_l
   | a#c_ad? x => if (In x v_l) then v_l else x::v_l
   | _ => nil
  end.

Definition update_c_l' (c_l: list string) (c : act): list string :=
  match c with
   | x ::= a => if (In x c_l) then c_l else x::c_l
   | a#c_ad! w => if (In c_ad c_l) then c_l else c_ad::c_l
   | _ => nil
  end.

Definition update_v_l (ev : env) (c : act) : list string :=
  update_v_l' (get_v_l ev) c.

Definition update_c_l (ev : env) (c : act) : list string :=
  update_c_l' (get_c_l ev) c.

Definition update_i_h_l' (l: list string) (i i' : string): list string :=
  match In i l with
  | true => if In i' l then l else i'::l
  | false => if In i' l then i::l else i::i'::l
  end.

Definition update_i_l (ev : env) (c : act): list string :=
  match c with
  | MOVEp(i)to(i') =>  update_i_h_l' (get_i_l ev) i i'
  | MOVEi(h)(i)to(h')(i') => update_i_h_l' (get_i_l ev) i i'
  | _ => get_i_l ev
 end.

Definition update_h_l (ev : env) (c : act): list string :=
  match c with
  | MOVEi(h)(i)to(h')(i') => update_i_h_l' (get_h_l ev) h h'
  | _ => get_h_l ev
 end.

Fixpoint acal_l (a : aexp) (lv : vc_level) : list string :=
  match a with
  | ANum n => nil
  | AVars x => match lv x with
              | None => nil
              | _ => [x]
              end
  | ACH x => match lv x with
              | None => nil
              | _ => [x]
              end
  | APlus a1 a2 => (acal_l a1 lv) ++ (acal_l a2 lv)
  | AMinus a1 a2  => (acal_l a1 lv) ++ (acal_l a2 lv)
  | AMult a1 a2 => (acal_l a1 lv) ++ (acal_l a2 lv)
  | ADiv a1 a2 => (acal_l a1 lv) ++ (acal_l a2 lv)
  end.

Fixpoint bcal_l (b : bexp) (lv : vc_level) : list string :=
  match b with
  | BEq a1 a2   => (acal_l a1 lv) ++ (acal_l a2 lv)
  | BLe a1 a2   => (acal_l a1 lv) ++ (acal_l a2 lv)
  | BNot b1     => (bcal_l b1 lv)
  | BAnd b1 b2  => (bcal_l b1 lv) ++ (bcal_l b2 lv)
  | _ => nil
  end.

Fixpoint update_tau' (v_ty c_ty tau : vc_level) (l:list string): vc_level :=
  match l with
    | [] => tau
    | [a] => match v_ty a with
            | High => match tau a with
                      | High => tau
                      | _ => a |-> High; tau
                      end
            | Medium => match tau a with
                      | High => tau
                      | Medium => tau
                      | _ => a |-> Medium; tau
                      end
            | Low => match tau a with
                      | None => a |-> Low; tau
                      | _ => tau
                     end
            | _  => match c_ty a with
                      | High => match tau a with
                               | High => tau
                               | _ => a |-> High; tau
                               end
                      | Medium => match tau a with
                               | High => tau
                               | Medium => tau
                               | _ => a |-> Medium; tau
                               end
                      | Low => match tau a with
                               | None => a |-> Low; tau
                               | _ => tau
                               end
                      | _ => tau
                      end
            end
    | a :: l => match v_ty a with
            | High => match tau a with
                      | High => update_tau' v_ty c_ty tau l
                      | _ => a |-> High; update_tau' v_ty c_ty tau l
                      end
            | Medium => match tau a with
                      | High => update_tau' v_ty c_ty tau l
                      | Medium => update_tau' v_ty c_ty tau l
                      | _ => a |-> Medium; update_tau' v_ty c_ty tau l
                      end
            | Low => match tau a with
                      | None => a |-> Low; update_tau' v_ty c_ty tau l
                      | _ => update_tau' v_ty c_ty tau l
                     end
            | _ => match c_ty a with
                  | High =>  match tau a with
                               | High => update_tau' v_ty c_ty tau l
                               | _ => a |-> High; update_tau' v_ty c_ty tau l
                               end
                  | Medium => match tau a with
                               | High => update_tau' v_ty c_ty tau l
                               | Medium => update_tau' v_ty c_ty tau l
                               | _ => a |-> Medium; update_tau' v_ty c_ty tau l
                               end
                  | Low => match tau a with
                               | None => a |-> Low; update_tau' v_ty c_ty tau l
                               | _ => update_tau' v_ty c_ty tau l
                               end
                  | _ => update_tau' v_ty c_ty tau l
                  end
            end
  end.

Definition update_tau (ev : env) (ju : jud) (l:list string): jud :=
  Jud (update_tau' (get_v_ty ev) (get_c_ty ev) (get_tau ju) l) (get_omegaI ju) (get_omegaH ju).

Definition update_ins_ty' (i_ty omegaI : i_level) (i i' : string) : i_level :=
  match omegaI i with
    | ins_1 => match i_ty i' with
              | ins_0 => match i_ty i with
                         | ins_1 => i_ty
                         | ins_2 => i |i|-> ins_2; i_ty
                         | _ => i |i|-> ins_1; i_ty
                         end
              | ins_1 => match i_ty i with
                         | ins_1 => i_ty
                         | ins_2 => i |i|-> ins_2; i_ty
                         | _ => i |i|-> ins_1; i_ty
                         end
              | ins_2 => match i_ty i with
                         | ins_2 => i_ty
                         | _ => i |i|-> ins_2; i_ty
                         end
              | _ => match i_ty i with
                         | ins_0 => i |i|-> ins_1; i_ty
                         | ins_none => i |i|-> ins_1; i_ty
                         | _ => i_ty
                         end
               end
    | ins_2 => match i_ty i with
              | ins_2 => i_ty
              | _ => i |i|-> ins_2; i_ty
              end
    | _ => match i_ty i' with
              | ins_0 => match i_ty i with
                         | ins_0 => i_ty
                         | ins_1 => i |i|-> ins_1; i_ty
                         | ins_2 => i |i|-> ins_2; i_ty
                         | _ => i |i|-> ins_0; i_ty
                         end
              | ins_1 => match i_ty i with
                         | ins_1 => i_ty
                         | ins_2 => i |i|-> ins_2; i_ty
                         | _ => i |i|-> ins_1; i_ty
                         end
              | ins_2 => match i_ty i with
                         | ins_2 => i_ty
                         | _ => i |i|-> ins_2; i_ty
                         end
              | _ => match i_ty i with
                         | ins_none => i |i|-> ins_0; i_ty
                         | _ => i_ty
                         end
             end
  end.

Definition update_ins_ty (ev : env) (ju : jud) (c : act) : i_level :=
  match c with
   | MOVEp(i)to(i') =>  update_ins_ty' (get_i_ty ev) (get_omegaI ju) i i'
   | MOVEi(h)(i)to(h')(i') => update_ins_ty' (get_i_ty ev) (get_omegaI ju) i i'
   | _ => get_i_ty ev
  end.

Definition update_hos_ty' (h_ty omegaH : h_level) (h h' : string) : h_level :=
  match omegaH h with
    | hos_1 => match h_ty h' with
              | hos_0 => match h_ty h with
                         | hos_1 => h_ty
                         | hos_2 => h |h|-> hos_2; h_ty
                         | _ => h |h|-> hos_1; h_ty
                         end
              | hos_1 => match h_ty h with
                         | hos_1 => h_ty
                         | hos_2 => h |h|-> hos_2; h_ty
                         | _ => h |h|-> hos_1; h_ty
                         end
              | hos_2 => match h_ty h with
                         | hos_2 => h_ty
                         | _ => h |h|-> hos_2; h_ty
                         end
              | _ => match h_ty h with
                         | hos_0 => h |h|-> hos_1; h_ty
                         | hos_none => h |h|-> hos_1; h_ty
                         | _ => h_ty
                         end
               end
    | hos_2 => match h_ty h with
              | hos_2 => h_ty
              | _ => h |h|-> hos_2; h_ty
              end
    | _ => match h_ty h' with
              | hos_0 => match h_ty h with
                         | hos_0 => h_ty
                         | hos_1 => h |h|-> hos_1; h_ty
                         | hos_2 => h |h|-> hos_2; h_ty
                         | _ => h |h|-> hos_0; h_ty
                         end
              | hos_1 => match h_ty h with
                         | hos_1 => h_ty
                         | hos_2 => h |h|-> hos_2; h_ty
                         | _ => h |h|-> hos_1; h_ty
                         end
              | hos_2 => match h_ty h with
                         | hos_2 => h_ty
                         | _ => h |h|-> hos_2; h_ty
                         end
              | _ => match h_ty h with
                         | hos_none => h |h|-> hos_0; h_ty
                         | _ => h_ty
                         end
             end
  end.

Definition update_hos_ty (ev : env) (ju : jud) (c : act) : h_level :=
  match c with
   | MOVEi(h)(i)to(h')(i') => update_hos_ty' (get_h_ty ev) (get_omegaH ju) h h'
   | _ => (get_h_ty ev)
  end.

Definition update_c_i' (c_i : c_ins) (ins_id : string) (x : string) : c_ins :=
  match prefix "0x" x with
  | true => if eqb_string ins_id (c_i x) then c_i else x |=> ins_id; c_i
  | false => c_i
  end.

Definition update_c_i (ev : env) (ins_id : string) (c : act) : c_ins :=
   match c with
   | x ::= a => update_c_i' (get_c_i ev) ins_id x
   | a#c_ad! w => update_c_i' (get_c_i ev) ins_id c_ad
   | _ => get_c_i ev
   end.

Fixpoint update_type_all (lv tau : vc_level) (list : list string): vc_level :=
  match list with
    | [] => empty_ty
    | [a] => match lv a with
            | High => lv
            | Medium => match tau a with
                      | High => a |-> High; lv
                      | _ => lv
                     end
            | _ => match tau a with
                      | High => a |-> High; lv
                      | Medium => a |-> Medium; lv
                      | _ => match lv a with
                             | Low => lv
                             | _ => a |-> Low; lv
                             end
                     end
            end
    | a :: l => match lv a with
            | High => update_type_all lv tau l
            | Medium => match tau a with
                      | High => a |-> High; update_type_all lv tau l
                      | _ => update_type_all lv tau l
                     end
            | _ => match tau a with
                      | High => a |-> High; update_type_all lv tau l
                      | Medium => a |-> Medium; update_type_all lv tau l
                      | _ => match lv a with
                             | Low => update_type_all lv tau l
                             | _ => a |-> Low; update_type_all lv tau l
                             end
                     end
            end
  end.

Definition update_type_all_s (ev : env) (ju : jud) : vc_level :=
  update_type_all (get_v_ty ev) (get_tau ju) (get_v_l ev).

Definition update_type_all_c (ev : env) (ju : jud) : vc_level :=
  update_type_all (get_c_ty ev) (get_tau ju) (get_c_l ev).

Fixpoint update_type_stop' (c_l : list string): vc_level :=
  match c_l with
    | [] => empty_ty
    | [a] => a |-> Low
    | a :: l => a |-> Low; update_type_stop' l
  end.

Definition update_type_stop (ev : env) : vc_level :=
  update_type_stop' (get_c_l ev).

Fixpoint update_c_i_all' (c_i : c_ins) (c_l : list string) (ins_id : string): c_ins :=
  match c_l with
    | [] => empty_c_i
    | [a] => a |=> ins_id
    | a :: l => a |=> ins_id; update_c_i_all' c_i l ins_id
  end.

Definition update_c_i_all (ev : env) (ins_id : string) : c_ins :=
  update_c_i_all' (get_c_i ev) (get_c_l ev) ins_id.

Definition update_st (st st_v st_c : state) (x : string) (a : aexp): state :=
  (x !-> acal st_v st_c a ; st).

Definition update_st_v (ev : env) (x : string) (a : aexp) : state :=
   update_st (get_st_v ev) (get_st_v ev) (get_st_c ev) x a.

Definition update_st_c (ev : env) (x : string) (a : aexp) : state :=
   update_st (get_st_c ev) (get_st_v ev) (get_st_c ev) x a.

Definition Ins1 : string := "Instance_id_1".
Definition Ins2 : string := "Instance_id_2".

Definition Host1 : string := "Host_id_1".
Definition Host2 : string := "Host_id_2".

Definition Error_ev :=
  Env empty_ty empty_ty [Error] [Error] empty_c_i empty_ins_ty empty_host_ty [Error] [Error] empty_st empty_st.

Definition IsErrorEv (ev : env): bool :=
  match ev with
  | Env v_ty c_ty v_l c_l c_i
        i_ty h_ty i_l h_l st_v st_c => match v_l with
                                            | [a] => eqb_string a Error
                                            | _ => false
                                            end
  end.

Fixpoint acttype (ev : env) (ins_id : string) (c : act) (ju : jud) (s : nat): env :=
match s with
   | O => ev
   | S s1 =>
     if IsErrorEv ev then Error_ev
     else match c with
     | x ::= a =>  match prefix "0x" x with
               | true => Env (get_v_ty ev) (update_type ev ju c) (get_v_l ev) (update_c_l ev c) (update_c_i ev ins_id c)
                             (get_i_ty ev) (get_h_ty ev) (get_i_l ev) (get_h_l ev)
                             (get_st_v ev) (update_st_c ev x a)
               | false => Env (update_type ev ju c) (get_c_ty ev) (update_v_l ev c) (get_c_l ev)  (get_c_i ev)
                              (get_i_ty ev) (get_h_ty ev) (get_i_l ev) (get_h_l ev)
                              (update_st_v ev x a) (get_st_c ev)
               end
     | c1;; c2 => let ev1 := acttype ev ins_id c1 ju s1 in acttype ev1 ins_id c2 ju s1
     | SKIP => ev
     | STOP =>  Env (get_v_ty ev) (update_type_stop ev) (get_v_l ev) (get_c_l ev) (get_c_i ev)
                (get_i_ty ev) (get_h_ty ev) (get_i_l ev) (get_h_l ev)
                (get_st_v ev) empty_st
     | MOVEp(i)to(i') => Env (update_type_all_s ev ju) (update_type_all_c ev ju) (get_v_l ev) (get_c_l ev) (update_c_i_all ev i')
                          (update_ins_ty ev ju c) (get_h_ty ev) (update_i_l ev c) (get_h_l ev)
                          (get_st_v ev) (get_st_c ev)
     | MOVEi(h)(i)to(h')(i') => Env (update_type_all_s ev ju) (update_type_all_c ev ju) (get_v_l ev) (get_c_l ev) (update_c_i_all ev i')
                                 (update_ins_ty ev ju c)  (update_hos_ty ev ju c) (update_i_l ev c) (update_h_l ev c)
                                 (get_st_v ev) (get_st_c ev)
     | SLEEP t => ev
     | IFB b THEN c1 ELSE c2 END => match bcal (get_st_v ev) (get_st_c ev) b with
                                | true => acttype ev ins_id c1 (update_tau ev ju (bcal_l b (get_v_ty ev) ++ bcal_l b (get_c_ty ev))) s1
                                | false => acttype ev ins_id c2 (update_tau ev ju (bcal_l b (get_v_ty ev) ++ bcal_l b (get_c_ty ev))) s1
                                end
     | ch#ad! a => Env (get_v_ty ev) (update_type ev ju c) (get_v_l ev) (update_c_l ev c) (update_c_i ev ins_id c)
                     (get_i_ty ev) (get_h_ty ev) (get_i_l ev) (get_h_l ev)
                     (get_st_v ev) (update_st_c ev ad a)
     | ch#ad? x => match acal (get_st_v ev) (get_st_c ev) (ACH ad) with
                | 0 => Error_ev
                | _ => Env (update_type ev ju c) (get_c_ty ev) (update_v_l ev c) (get_c_l ev) (get_c_i ev)
                           (get_i_ty ev) (get_h_ty ev)(get_i_l ev) (get_h_l ev)
                           (update_st_v ev x (ACH ad)) (get_st_c ev)
                end
     | WHILE b DO c1 END => match bcal (get_st_v ev) (get_st_c ev) b with
                        | true => let ev1 := acttype ev ins_id c1 (update_tau ev ju (bcal_l b (get_v_ty ev) ++ bcal_l b (get_c_ty ev))) s1 in
                                  acttype ev1 ins_id c (update_tau ev ju (bcal_l b (get_v_ty ev) ++ bcal_l b (get_c_ty ev))) s1
                        | false => ev
                        end
     | c1//c2 => let ev1 := acttype ev ins_id c1 ju s1 in acttype ev1 ins_id c2 ju s1
end
 end.

Definition MaxStep : nat := 20.

Notation " '|-' ( ev ) ':' '[' ins_id ']' ( c ) '\IN' ( ju )" :=
   (acttype ev ins_id c ju MaxStep) (at level 90, right associativity).

Axiom Cpar_eq1 : forall (c1 c2 : act),
(c1 // c2) = (c2 // c1).

Axiom Cpar_eq2 : forall (c1 c2 c3: act),
(c1 // c2 // c3) = (c2 // c1 // c3).

Definition eqb_ty (a b : ty) : bool :=
   match a with
      | High => match b with
                | High => true
                | _ => false
                end
      | Medium => match b with
                | Medium => true
                | _ => false
                end
      | Low => match b with
                | Low => true
                | _ => false
                end
      | None => match b with
                | None => true
                | _ => false
                end
end.

Fixpoint check_ty (lv tau : vc_level) (list : list string) : bool :=
  match list with
    | [] => true
    | [a] => eqb_ty (lv a) (tau a)
    | a :: l => match eqb_ty (lv a) (tau a) with
                | true => check_ty lv tau l
                | false => false
                end
  end.

Definition eqb_ins_ty (a b : ins_ty) : bool :=
   match a with
      | ins_0 => match b with
                | ins_0 => true
                | _ => false
                end
      | ins_1 => match b with
                | ins_1 => true
                | _ => false
                end
      | ins_2 => match b with
                | ins_2 => true
                | _ => false
                end
      | ins_none => match b with
                | ins_none => true
                | _ => false
                end
end.

Fixpoint check_ins_ty (i_ty omegal: i_level) (list : list string) : bool :=
  match list with
    | [] => true
    | [a] => eqb_ins_ty (i_ty a) (omegal a)
    | a :: l => match eqb_ins_ty (i_ty a) (omegal a) with
                | true => check_ins_ty i_ty omegal l
                | false => false
                end
  end.

Definition eqb_hos_ty (a b : hos_ty) : bool :=
   match a with
      | hos_0 => match b with
                | hos_0 => true
                | _ => false
                end
      | hos_1 => match b with
                | hos_1 => true
                | _ => false
                end
      | hos_2 => match b with
                | hos_2 => true
                | _ => false
                end
      | hos_none => match b with
                | hos_none => true
                | _ => false
                end
end.

Fixpoint check_hos_ty (h_ty omegaH: h_level) (list : list string) : bool :=
  match list with
    | [] => true
    | [a] => eqb_hos_ty (h_ty a) (omegaH a)
    | a :: l => match eqb_hos_ty (h_ty a) (omegaH a) with
                | true => check_hos_ty h_ty omegaH l
                | false => false
                end
  end.

Fixpoint repeat_assign (st : state)(x : string) (v n: nat): state :=
  match n with
   | O => st
   | S n' => let st1 := (x !-> v ; st) in
                repeat_assign st1 x v n'
  end.

Definition Check_type_judgement (ev : env) (ju : jud) : bool :=
  check_ty (get_v_ty ev) (get_tau ju) (get_v_l ev) && check_ty (get_c_ty ev) (get_tau ju) (get_c_l ev)
  && check_ins_ty (get_i_ty ev)(get_omegaI ju) (get_i_l ev)
  && check_hos_ty (get_h_ty ev)(get_omegaH ju) (get_h_l ev).

Fixpoint check_process_no_rec (ev : env) (c : act) : bool :=
    match c with
  | a#c_ad? x => match acal (get_st_v ev) (get_st_c ev) (ACH c_ad) with
                | 0 => false
                | _ => true
                end
  | c1;; c2 => check_process_no_rec ev c1 && check_process_no_rec ev c2
  | IFB b THEN c1 ELSE c2 END => check_process_no_rec ev c1 && check_process_no_rec ev c2
  | WHILE b DO c END => check_process_no_rec ev c
  | c1//c2 => check_process_no_rec ev c1 && check_process_no_rec ev c2
  | _ => true
end.

(* Only the right side has a receiving action in parallel processes_1 *)
Axiom Cpar_right_yes_1 : forall (p q q' : act) (ev ev': env)  (ins : string) (ju : jud) (a : channel) (c_ad x : string),
  check_process_no_rec ev p = true ->
  check_process_no_rec ev q = true ->
  |- ( ev ) : [ ins ] ( p//q ) \IN ( ju ) = ev' ->
  |- ( ev ) : [ ins ] ( p//q;; (a#c_ad? x) ;; q' ) \IN ( ju ) =
    |- ( ev' ) : [ ins ] ( (a#c_ad? x) ;; q' ) \IN ( ju ).

(* Only the right side has a receiving action in parallel processes_2 *)
Axiom Cpar_right_yes_2 : forall (p q' : act) (ev ev': env)  (ins : string) (ju : jud) (a : channel) (c_ad x : string),
  check_process_no_rec ev p = true ->
  |- ( ev ) : [ ins ] ( p ) \IN ( ju ) = ev' ->
  |- ( ev ) : [ ins ] ( p//(a#c_ad? x) ;; q' ) \IN ( ju ) =
    |- ( ev' ) : [ ins ] ( (a#c_ad? x) ;; q' ) \IN ( ju ).

(* Both sides have receiving actions in parallel processes_1 *)
Axiom Cpar_both_yes_1 : forall (p p' q q' : act) (ev ev': env)  (ins : string) (ju : jud) (a1 a2 : channel) (c_ad1 x1 c_ad2 x2: string),
  check_process_no_rec ev p = true ->
  check_process_no_rec ev q = true ->
  |- ( ev ) : [ ins ] ( p//q ) \IN ( ju ) = ev' ->
  |- ( ev ) : [ ins ] ( p;; (a1#c_ad1? x1);; p'//q;; (a2#c_ad2? x2);; q' ) \IN ( ju ) =
    |- ( ev' ) : [ ins ] ( (a1#c_ad1? x1);; p'//(a2#c_ad2? x2);; q' ) \IN ( ju ).

(* Both sides have receiving actions in parallel processes_2 *)
Axiom Cpar_both_yes_2 : forall (p p' q' : act) (ev ev': env)  (ins : string) (ju : jud) (a1 a2 : channel) (c_ad1 x1 c_ad2 x2: string),
  check_process_no_rec ev p = true ->
  |- ( ev ) : [ ins ] ( p ) \IN ( ju ) = ev' ->
  |- ( ev ) : [ ins ] ( p;; (a1#c_ad1? x1);; p'//(a2#c_ad2? x2);; q' ) \IN ( ju ) =
    |- ( ev' ) : [ ins ] ( (a1#c_ad1? x1);; p'//(a2#c_ad2? x2);; q' ) \IN ( ju ).

(* Perform parallel processes step by step *)
Axiom Cpar_step : forall (p q: act) (ev ev': env) (ins : string) (ju : jud) ,
  check_process_no_rec ev p = true ->
  |- ( ev ) : [ ins ] ( p ) \IN ( ju ) = ev' ->
  |- ( ev ) : [ ins ] ( p // q ) \IN ( ju ) =
    |- ( ev' ) : [ ins ] ( q ) \IN ( ju ).

(* Test Examples *)

Definition empty_ev :=
  Env empty_ty empty_ty nil nil empty_c_i (Ins1 |i|-> ins_0) (Host1 |h|-> hos_0) [Ins1] [Host1] empty_st empty_st.

Definition empty_ev' :=
  Env empty_ty empty_ty nil nil empty_c_i
      (Ins1 |i|-> ins_0; Ins2 |i|-> ins_1) (Host1 |h|-> hos_0; Host2 |h|-> hos_1)
      [Ins1;Ins2] [Host1;Host2]  empty_st empty_st.

Definition tau' := Y |-> Low; Z |-> Low; X |-> High; "0x21d36e0"%string |-> High.
Definition ju' := Jud tau' empty_ins_ty empty_host_ty.
Definition omegaI' := Ins1 |i|-> ins_2.
Definition omegaH' := Host1 |h|-> hos_2.
Definition ju := Jud tau' omegaI' omegaH'.

Definition list' := [Z;Y;"0x21d36e0"%string].
Definition v_ty' := Y |-> High; X |-> Low; Z |-> Low.
Definition c_ty' := "0x21d36e0" |-> High.
Definition tao' := Z |-> High.

Definition i_ty := Ins1 |i|-> ins_0; Ins2 |i|-> ins_1.
Definition i_id' := "0x21d36e0" |=> Ins1.

Example test_example_0:
  |- (empty_ev) : [Ins1](X ::= 0 ;; SKIP // Z ::= 2) \IN (ju') =
  Env (Z |-> Low; X |-> High) empty_ty [ Z ; X ] nil empty_c_i
      (Ins1 |i|-> ins_0) (Host1 |h|-> hos_0) [Ins1] [Host1] (Z !-> 2; X !-> 0) empty_st.
Proof.
  unfold acttype. simpl.
  reflexivity. Qed.

Example test_example_1:
  |- (empty_ev) : [Ins1](X ::= 0;; "0x21d36e0" ::= 1;; Y ::= X) \IN (ju') =
  Env (Y |-> High; X |-> High) ("0x21d36e0" |-> High) [ Y ; X ] ["0x21d36e0"%string] ("0x21d36e0" |=> Ins1)
      (Ins1 |i|-> ins_0) (Host1 |h|-> hos_0) [Ins1] [Host1] (Y !-> 0 ; X !-> 0) ("0x21d36e0" !-> 1).
Proof.
  reflexivity. Qed.

Example test_example_2:
  |- (empty_ev) : [Ins1](SLEEP 1 ;; X ::= 0;; "0x21d36e0" ::= 1) \IN (ju') =
  Env (X |-> High) ("0x21d36e0" |-> High) [ X ] ["0x21d36e0"%string] ("0x21d36e0" |=> Ins1)
      (Ins1 |i|-> ins_0) (Host1 |h|-> hos_0) [Ins1] [Host1] (X !-> 0) ("0x21d36e0" !-> 1).
Proof.
   reflexivity. Qed.

Example test_example_3:
  |- (empty_ev) : [Ins1](X ::= 3;; IFB X = 1 THEN Z ::= 0;; "0x21d36e0" ::= 1 ELSE Z ::= 2 END) \IN (ju') =
  Env (Z |-> Low; X |-> High) empty_ty [ Z; X ] nil empty_c_i
       (Ins1 |i|-> ins_0) (Host1 |h|-> hos_0) [Ins1] [Host1] (Z !-> 2 ; X !-> 3) empty_st.
Proof.
  reflexivity. Qed.

Example test_example_4:
  |- (empty_ev) : [Ins1](X ::= 1;; Z ::= 2;; (CH 0#"0x21d36e0" ! Z + X)) \IN (ju') =
  Env  (Z |-> Low; X |-> High) ("0x21d36e0" |-> High) [ Z; X ] ["0x21d36e0"%string] ("0x21d36e0" |=> Ins1)
       (Ins1 |i|-> ins_0) (Host1 |h|-> hos_0) [Ins1] [Host1] (Z !-> 2 ; X !-> 1) ("0x21d36e0" !-> 3).
Proof.
  reflexivity. Qed.

Example test_example_5:
  |- (empty_ev) : [Ins1]("0x21d36e0" ::= 3;; (CH 0#"0x21d36e0" ? Y)) \IN (ju') =
  Env  (Y |-> High) ("0x21d36e0" |-> High) [ Y ] ["0x21d36e0"%string] ("0x21d36e0" |=> Ins1)
       (Ins1 |i|-> ins_0) (Host1 |h|-> hos_0) [Ins1] [Host1] (Y !-> 3) ("0x21d36e0" !-> 3).
Proof.
  reflexivity. Qed.

Example test_example_6:
  |- (empty_ev) : [Ins1]((CH 0#"0x21d36e0" ? Y);; SKIP// X ::= 1;; (CH 0#"0x21d36e0" ! X)) \IN (ju') =
  Env (Y |-> High; X |-> High) ("0x21d36e0" |-> High) [ Y; X ] ["0x21d36e0"%string] ("0x21d36e0" |=> Ins1)
     (Ins1 |i|-> ins_0) (Host1 |h|-> hos_0) [Ins1] [Host1] (Y !-> 1 ; X !-> 1) ("0x21d36e0" !-> 1).
Proof.
  rewrite Cpar_eq1. reflexivity. Qed.

Definition while_test : act :=
  (X ::= 1;;
  Z ::= X;;
  Y ::= 1;;
  WHILE ~(Z = 0) DO
    Y ::= Y * Z;;
    Z ::= Z - 1
  END).

Example test_example_7:
  |- (empty_ev) : [Ins1](while_test) \IN (ju') =
  Env (Y |-> High; Y |-> Low; Z |-> High; X |-> High) empty_ty [ Y; Z; X ] nil empty_c_i
      (Ins1 |i|-> ins_0) (Host1 |h|-> hos_0) [Ins1] [Host1] (Z !-> 0; Y !-> 1; Y !-> 1; Z !-> 1; X !-> 1) empty_st.
Proof.
  reflexivity.
Qed.

Definition R' : act :=
  (WHILE true DO
    X ::= 1
  END).

Example test_example_8:
 |- (empty_ev) : [Ins1](R') \IN (ju') =
 Env (X |-> High) empty_ty [ X ] nil empty_c_i
      (Ins1 |i|-> ins_0) (Host1 |h|-> hos_0) [Ins1] [Host1] (repeat_assign empty_st X 1 (MaxStep-1)) empty_st.
Proof.

  reflexivity. Qed.

Definition v_ty'' := Y |-> Low; X |-> Low; Z |-> Low.
Definition c_ty'' := "0x21d36e0" |-> Low; "0x21d3fff"%string |-> Low.
Definition list_v'' := [ Y; X ].
Definition list_c'' := ["0x21d36e0"%string; "0x21d3fff"%string].

Definition empty_ev'' :=
  Env v_ty'' c_ty'' list_v'' list_c''  ("0x21d36e0"%string |=> Ins1;"0x21d3fff"%string |=> Ins1)
      (Ins1 |i|-> ins_0; Ins2 |i|-> ins_1) (Host1 |h|-> hos_0; Host2 |h|-> hos_1) [Ins1;Ins2] [Host1;Host2] empty_st empty_st.

Example test_example_9:
  |- (empty_ev'') : [Ins1](MOVEp(Ins1)to(Ins2)) \IN (ju) =
  Env (X |-> High;v_ty'') ("0x21d36e0" |-> High;c_ty'') list_v'' list_c'' ("0x21d36e0"%string |=> Ins2;"0x21d3fff"%string |=> Ins2)
      (Ins1 |i|-> ins_2; Ins1 |i|-> ins_0; Ins2 |i|-> ins_1) (Host1 |h|-> hos_0; Host2 |h|-> hos_1) [Ins1;Ins2] [Host1;Host2] empty_st empty_st.
Proof.
  reflexivity. Qed.
Definition ev_1 := |- (empty_ev'') : [Ins1](SKIP) \IN (ju).

Example test_example_10:
  |- (empty_ev'') : [Ins1](MOVEi(Host1)(Ins1)to(Host2)(Ins2)) \IN (ju) =
  Env (X |-> High;v_ty'') ("0x21d36e0" |-> High;c_ty'') list_v'' list_c'' ("0x21d36e0"%string |=> Ins2;"0x21d3fff"%string |=> Ins2)
      (Ins1 |i|-> ins_2; Ins1 |i|-> ins_0; Ins2 |i|-> ins_1) (Host1 |h|-> hos_2; Host1 |h|-> hos_0; Host2 |h|-> hos_1) [Ins1;Ins2] [Host1;Host2] empty_st empty_st.
Proof.
    reflexivity. Qed.

Example test_example_11:
  |- (empty_ev) : [Ins1](Y ::= 1;; (CH 0#"0x21d3fff" ! Y);; SKIP//X ::= 2;; Y ::= X;; (CH 0#"0x21d3fff" ! Y);; SKIP) \IN (ju') =
  Env (Y |-> High; X |-> High; Y |-> Low) ("0x21d3fff" |-> High; "0x21d3fff" |-> Low) [ X; Y ] ["0x21d3fff"%string] ("0x21d3fff" |=> Ins1)
      (Ins1 |i|-> ins_0) (Host1 |h|-> hos_0) [Ins1] [Host1] (Y !-> 2; X !-> 2; Y !-> 1) ("0x21d3fff" !-> 2; "0x21d3fff" !-> 1).
Proof.
   reflexivity. Qed.

(* Paper Examples *)

Definition P : act :=
  (X ::= 1;;
  (CH 0#"0x21d36e0" ! X)).

Definition P1 : act :=
  (CH 1#"0x21d3fff" ? M2).

Definition P2 : act :=
  ( M ::= X + M2;;
  SKIP).

Definition Q : act :=
  (CH 0#"0x21d36e0" ? Y).

Definition Q1 : act :=
  M1 ::= Y;;
  (CH 1#"0x21d3fff" ! M1);;
  SKIP.

Definition R : act :=
  (WHILE true DO
    Z ::= "0x21d36e0"%string
  END).

Definition tau_1 := X |-> High; Y |-> High; M1 |-> Medium; M2 |-> Medium; Z |-> Low; "0x21d36e0"%string |-> High; "0x21d3fff"%string |-> Medium.
Definition ju_1 := Jud tau_1 (Ins1 |i|-> ins_0; Ins2 |i|-> ins_0) (Host1 |h|-> hos_0).

Example paper_example_0:
  Check_type_judgement (|- (empty_ev) : [Ins1](P;;Q) \IN (ju_1)) ju_1 = true.
Proof.
   reflexivity.
Qed.

Example paper_example_1:
  Check_type_judgement (|- (empty_ev) : [Ins1](P;;R;;Q;;Q1;;P1;;P2) \IN (ju_1)) ju_1 = false.
Proof.
  reflexivity.
Qed.

Example paper_new_example_1_err:
  |- (empty_ev) : [Ins1]((P;;P1;;P2)//
                         (Q;;Q1)) \IN (ju_1) =
  Error_ev.
Proof.
  unfold acttype. simpl.
  reflexivity. Qed.

Definition mid_ev_1 := Env (X |-> High) ("0x21d36e0" |-> High) [X] ["0x21d36e0"%string] ("0x21d36e0" |=> Ins1) (Ins1 |i|-> ins_0) (Host1 |h|-> hos_0) [Ins1] [Host1]
  (X !-> 1) ("0x21d36e0" !-> 1).
Definition mid_ev_2 := Env (M1 |-> High; Y |-> High; X |-> High) ("0x21d3fff" |-> High; "0x21d36e0" |-> High) [M1; Y; X] ["0x21d3fff"%string; "0x21d36e0"%string]
  ("0x21d3fff" |=> Ins1; "0x21d36e0" |=> Ins1) (Ins1 |i|-> ins_0) (Host1 |h|-> hos_0) [Ins1] [Host1]
  (M1 !-> 1; Y !-> 1; X !-> 1)
  ("0x21d3fff" !->1; "0x21d36e0" !-> 1).
Definition mid_ev_3 := Env (M |-> High; M2 |-> High; M1 |-> High; Y |-> High; X |-> High) ("0x21d3fff" |-> High; "0x21d36e0" |-> High) [M; M2; M1; Y; X] ["0x21d3fff"%string; "0x21d36e0"%string]
  ("0x21d3fff" |=> Ins1; "0x21d36e0" |=> Ins1) (Ins1 |i|-> ins_0) (Host1 |h|-> hos_0) [Ins1] [Host1]
  (M !-> 2; M2 !-> 1; M1 !-> 1; Y !-> 1; X !-> 1)
  ("0x21d3fff" !->1; "0x21d36e0" !-> 1).

Example paper_new_example_1:
  |- (empty_ev) : [Ins1]((P;;P1;;P2)//
                         (Q;;Q1)) \IN (ju_1) =
  Env (M |-> High; M2 |-> High; M1 |-> High; Y |-> High; X |-> High) ("0x21d3fff" |-> High; "0x21d36e0" |-> High) [M; M2; M1; Y; X]
  ["0x21d3fff"%string; "0x21d36e0"%string] ("0x21d3fff" |=> Ins1; "0x21d36e0" |=> Ins1) (Ins1 |i|-> ins_0) (Host1 |h|-> hos_0) [Ins1] [Host1]
  (M !->2; M2 !-> 1; M1 !-> 1; Y !-> 1; X !-> 1) ("0x21d3fff" !-> 1; "0x21d36e0" !-> 1).
Proof.
  assert (HM1: |- (empty_ev) : [Ins1]((P;;P1;;P2)//(Q;;Q1)) \IN (ju_1) =
   |- (mid_ev_1) : [Ins1]((P1;;P2)//(Q;;Q1)) \IN (ju_1)).
  { apply Cpar_both_yes_2; reflexivity. }
  rewrite HM1. rewrite Cpar_eq1.
  assert (HM2: |- (mid_ev_1) : [Ins1]((Q;;Q1)//(P1;;P2)) \IN (ju_1) =
    |- (mid_ev_2) : [Ins1](P1;;P2) \IN (ju_1)).
  { apply Cpar_right_yes_2; reflexivity. }
  rewrite HM2. reflexivity. Qed.

Example paper_new_example_1'_err:
  |- (empty_ev) : [Ins1]((P;;P1;;P2)//
                         (Q;;Q1)//R) \IN (ju_1) =
  Error_ev.
Proof.
  reflexivity. Qed.

Example paper_new_example_1':
  |- (empty_ev) : [Ins1]((P;;P1;;P2)//
                         (Q;;Q1)//R) \IN (ju_1) =
  Env (Z |-> High; M |-> High; M2 |-> High; M1 |-> High; Y |-> High; X |-> High) ("0x21d3fff" |-> High; "0x21d36e0" |-> High)
  [Z; M; M2; M1; Y; X] ["0x21d3fff"%string; "0x21d36e0"%string] ("0x21d3fff" |=> Ins1; "0x21d36e0" |=> Ins1) (Ins1 |i|-> ins_0)
  (Host1 |h|-> hos_0) [Ins1] [Host1]
  (repeat_assign (M !-> 2; M2 !-> 1; M1 !-> 1; Y !-> 1; X !-> 1) Z 1 (MaxStep-1)) ("0x21d3fff" !-> 1; "0x21d36e0" !-> 1).
Proof.
  assert (HM1: |- (empty_ev) : [Ins1]((P;;P1;;P2)//(Q;;Q1)//R) \IN (ju_1) =
   |- (mid_ev_1) : [Ins1]((P1;;P2)//(Q;;Q1)//R) \IN (ju_1)).
  { apply (@Cpar_both_yes_2 P P2 (Q1//R) empty_ev mid_ev_1 Ins1 ju_1 (CH 1) (CH 0) "0x21d3fff" M2 "0x21d36e0" Y); reflexivity. }
  rewrite HM1.
  assert (HM2: ((P1;;P2)//(Q;;Q1)//R) = (Q;;Q1//P1;;P2//R)).
  { apply Cpar_eq2. }
  rewrite HM2.
  assert (HM3: |- (mid_ev_1) : [Ins1]((Q;;Q1)//(P1;;P2)//R) \IN (ju_1) =
    |- (mid_ev_2) : [Ins1]((P1;;P2)//R) \IN (ju_1)).
    { apply Cpar_step;reflexivity. }
  rewrite HM3.
  assert (HM4: |- (mid_ev_2) : [Ins1]((P1;;P2)//R) \IN (ju_1) =
  |- (mid_ev_3) : [Ins1](R) \IN (ju_1)).
  { apply Cpar_step;reflexivity.  }
  rewrite HM4.
  reflexivity. Qed.

Definition final_ev := Env (Z |-> High; M |-> High; M2 |-> High; M1 |-> High; Y |-> High; X |-> High) ("0x21d3fff" |-> High; "0x21d36e0" |-> High)
  [Z; M; M2; M1; Y; X] ["0x21d3fff"%string; "0x21d36e0"%string] ("0x21d3fff" |=> Ins1; "0x21d36e0" |=> Ins1) (Ins1 |i|-> ins_0)
  (Host1 |h|-> hos_0) [Ins1] [Host1]
  (repeat_assign (M !-> 2; M2 !-> 1; M1 !-> 1; Y !-> 1; X !-> 1) Z 1 (MaxStep-1)) ("0x21d3fff" !-> 1; "0x21d36e0" !-> 1).

Example check_paper_new_example_1':
  Check_type_judgement final_ev ju_1 = false.
Proof.
  reflexivity.
Qed.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A B C D E F : Universe, ((wd_ A B /\ (wd_ A C /\ (wd_ B C /\ (wd_ B D /\ (wd_ A D /\ (wd_ C D /\ (wd_ C F /\ (wd_ A D /\ (wd_ D E /\ (wd_ A E /\ (wd_ B D /\ (col_ A B C /\ (col_ A D E /\ col_ B D E))))))))))))) -> col_ A C D)).
Proof.
  time tac.
Qed.

End FOFProblem.


(** * Equivalence up to taus *)

(** Abbreviated as [eutt]. *)

(** We consider [Tau] as an "internal step", that should not be
   visible to the outside world, so adding or removing [Tau]
   constructors from an itree should produce an equivalent itree.

   We must be careful because there may be infinite sequences of
   taus (i.e., [spin]). Here we shall only allow inserting finitely
   many [Tau]s between any two visible steps ([Ret] or [Vis]), so that
   [spin] is only related to itself. This ensures that equivalence
   up to taus is transitive (and in fact an equivalence relation).
 *)

(** A rewrite hint database named [itree] is available via the tactic
    [autorewrite with itree] as a custom simplifier of expressions using
    mainly [Ret], [Tau], [Vis], [ITree.bind] and [ITree.Interp.Interp.interp].
 *)

(** This file contains only the definition of the [eutt] relation.
    Theorems about [eutt] are split in two more modules:

    - [ITree.Eq.UpToTausCore] proves that [eutt] is reflexive, symmetric,
      and that [ITree.Eq.Eq.eq_itree] is a subrelation of [eutt].
      Equations for [ITree.Core.ITreeDefinition] combinators which only rely on
      those properties can also be found here.

    - [ITree.Eq.UpToTausEquivalence] proves that [eutt] is transitive,
      and, more generally, contains theorems for up-to reasoning in
      coinductive proofs.
 *)

(** Splitting things this way makes the library easier to build in parallel.
 *)

(* begin hide *)
From Coq Require Import Setoid Morphisms RelationClasses.
From Paco Require Import paco.

From ITree Require Import
     Core.ITreeDefinition
     Eq.Eq
     Eq.Paco2
     Eq.Shallow.

Local Open Scope itree_scope.
(* end hide *)

(** ** gpaco
*)

Tactic Notation "gpaco_" :=
  match goal with
  | [|- context[gpaco2]] => eapply gpaco2_gpaco; [eauto with paco|]
  end.
Ltac gpaco := repeat red; under_forall ltac:(gpaco_).

(**** END ****)

Section EUTTG.

Context {E : Type -> Type} {R1 R2 : Type} (RR : R1 -> R2 -> Prop).

Definition transU := @eqit_trans_clo E R1 R2 RR true true true true.
Definition transD := @eqit_trans_clo E R1 R2 RR true true false false.
Definition bindC := @eqit_bind_clo E R1 R2 true true.

Definition euttVC gH r :=
  gupaco2 (eqit_ RR true true id) transD (transU (r \2/ gH)).

Variant euttG rH rL gL gH t1 t2 : Prop :=
| euttG_intro
    (IN: gpaco2 (@eqit_ E R1 R2 RR true true (euttVC gH)) transD (transU rH \2/ rL) gL t1 t2)
.

Hint Unfold transU transD bindC euttVC: core.
Hint Constructors euttG: core.

Lemma transD_mon r1 r2 t1 t2
      (IN: transD r1 t1 t2)
      (LE: r1 <2= r2):
  transD r2 t1 t2.
Proof. eapply eqitC_mon, LE; eauto. Qed.

Lemma transU_mon r1 r2 t1 t2
      (IN: transU r1 t1 t2)
      (LE: r1 <2= r2):
  transU r2 t1 t2.
Proof.
  destruct IN. econstructor; eauto.
Qed.

Lemma transDleU: transD <3= transU.
Proof.
  intros. destruct PR. econstructor; eauto using eqit_mon.
Qed.

Lemma transD_compose:
  compose transD transD <3= transD.
Proof.
  intros. destruct PR. destruct REL.
  econstructor; try eapply eqit_trans; eauto; auto_ctrans.
Qed.

Lemma transU_compose:
  compose transU transU <3= transU.
Proof.
  intros. destruct PR. destruct REL.
  econstructor; try eapply eqit_trans; eauto; auto_ctrans.
Qed.

Lemma transD_id: id <3= transD.
Proof. intros. econstructor; try reflexivity; auto_ctrans. Qed.

Lemma transU_id: id <3= transU.
Proof. intros. econstructor; try reflexivity; auto_ctrans. Qed.

Hint Resolve transD_mon transU_mon : paco.

Lemma euttVC_mon gH:
  monotone2 (euttVC gH).
Proof.
  red; intros.
  eapply gupaco2_mon; eauto. intros.
  eapply transU_mon; eauto. intros.
  destruct PR0; eauto.
Qed.
Hint Resolve euttVC_mon : paco.

Lemma euttVC_compat gH:
  compose transD (euttVC gH) <3= compose (euttVC gH) transD.
Proof.
  intros. gclo. eapply transD_mon; eauto. intros.
  eapply gupaco2_mon; eauto. intros.
  eapply transU_mon; eauto. intros.
  destruct PR2; eauto.
  left. econstructor; try reflexivity; auto_ctrans.
Qed.
Hint Resolve euttVC_compat : paco.

Lemma euttVC_id gH:
  id <3= euttVC gH.
Proof.
  intros. gbase. econstructor; try reflexivity; auto_ctrans.
Qed.
Hint Resolve euttVC_id : paco.

End EUTTG.

Global Hint Unfold transU transD bindC euttVC: core.
Global Hint Constructors euttG: core.
Global Hint Resolve transD_mon transU_mon : paco.
Global Hint Resolve euttVC_mon : paco.
Global Hint Resolve euttVC_compat : paco.
Global Hint Resolve transD_id transU_id euttVC_id : paco.

#[global]
Instance geuttG_cong_euttge {E R1 R2 RR} gH r g:
  Proper (euttge eq ==> euttge eq ==> flip impl)
         (gpaco2 (@eqit_ E R1 R2 RR true true (euttVC RR gH)) (transD RR) r g).
Proof.
  repeat intro. guclo eqit_clo_trans. econstructor; eauto; auto_ctrans.
Qed.

#[global]
Instance geuttG_cong_eq {E R1 R2 RR} gH r g:
  Proper (eq_itree eq ==> eq_itree eq ==> flip impl)
         (gpaco2 (@eqit_ E R1 R2 RR true true (euttVC RR gH)) (transD RR) r g).
Proof.
  repeat intro. eapply geuttG_cong_euttge; eauto using eqit_mon.
Qed.

Lemma eqit_ret_gen {E R1 R2 RR} t v
      (IN: @eqit E R1 R2 RR true true t (Ret v)):
  eqit RR true false t (Ret v).
Proof.
  punfold IN. pstep. red in IN |- *. simpl in *.
  remember (RetF v) as ot.
  hinduction IN before RR; intros; subst; eauto; inv Heqot.
Qed.

Section EUTTG_Properties1.

Context {E : Type -> Type} {R1 R2 : Type} (RR : R1 -> R2 -> Prop).

Local Notation euttG := (@euttG E R1 R2 RR).

Lemma rclo_transD r:
  rclo2 (transD RR) r <2= @transD E R1 R2 RR r.
Proof.
  intros. induction PR; eauto with paco.
  destruct IN. apply H in REL. destruct REL.
  econstructor; try apply REL; try eapply eqit_trans; eauto; auto_ctrans.
Qed.

Lemma rclo_flip clo (r: itree E R1 -> itree E R2 -> Prop)
      (MON: monotone2 clo):
  flip (rclo2 (fun x : itree E R2 -> itree E R1 -> Prop => flip (clo (flip x))) (flip r)) <2= rclo2 clo r.
Proof.
  intros. induction PR; eauto with paco.
  apply rclo2_clo; eauto.
Qed.

Lemma transD_flip r:
  flip (transD (flip RR) (flip r)) <2= @transD E _ _ RR r.
Proof.
  unfold flip. intros. destruct PR. econstructor; eauto.
Qed.

Lemma transU_flip r:
  flip (transU (flip RR) (flip r)) <2= @transU E R1 R2 RR r.
Proof.
  unfold flip. intros. destruct PR. econstructor; eauto.
Qed.

Lemma euttVC_flip gH r:
  flip (euttVC (flip RR) (flip gH) (flip r)) <2= @euttVC E R1 R2 RR gH r.
Proof.
  pcofix CIH. intros. gunfold PR.
  gclo. apply rclo_transD.
  eapply rclo_flip; eauto with paco.
  eapply rclo2_mon_gen; eauto; intros.
  { eapply transD_flip. eauto. }
  destruct PR0; cycle 1.
  { gbase. destruct H; eauto using transU_flip. }
  gstep. apply eqitF_flip.
  eapply eqitF_mono; eauto with paco. intros.
  gbase. eapply CIH.
  eapply gupaco2_mon; eauto. intros.
  destruct PR1; eauto.
Qed.

Lemma euttG_flip gH r:
  flip (gupaco2 (eqit_ (flip RR) true true (euttVC (flip RR) (flip gH))) (transD (flip RR)) (flip r)) <2=
  gupaco2 (@eqit_ E R1 R2 RR true true (euttVC RR gH)) (transD RR) r.
Proof.
  pcofix CIH; intros.
  destruct PR. econstructor.
  eapply rclo_flip; eauto with paco.
  eapply rclo2_mon_gen; eauto using transD_flip. intros.
  destruct PR; eauto.
  left. punfold H. pstep. apply eqitF_flip.
  eapply eqitF_mono; eauto with paco; intros.
  - eapply euttVC_flip. apply PR.
  - apply rclo_flip; eauto with paco.
    eapply rclo2_mon_gen; eauto using transD_flip with paco.
    intros. right. left. destruct PR0.
    + eapply CIH. red. eauto with paco.
    + apply CIH0. destruct H0; eauto.
Qed.

Lemma transD_dist:
  forall r1 r2, @transD E R1 R2 RR (r1 \2/ r2) <2= (transD RR r1 \2/ transD RR r2).
Proof. apply eqitC_dist. Qed.

Lemma transU_dist:
  forall r1 r2, @transU E R1 R2 RR (r1 \2/ r2) <2= (transU RR r1 \2/ transU RR r2).
Proof.
  intros. destruct PR. destruct REL; eauto.
Qed.

Lemma transU_dist_rev:
  forall r1 r2, (transU RR r1 \2/ transU RR r2) <2= @transU E R1 R2 RR (r1 \2/ r2).
Proof.
  intros. destruct PR, H; eauto.
Qed.

Variant transL (r: itree E R1 -> itree E R2 -> Prop) (t1: itree E R1) (t2: itree E R2) : Prop :=
| transL_intro t' RR1
               (EQL: eqit RR1 true true t1 t')
               (EQR: r t' t2)
               (LERR: forall x x' y, RR1 x x' -> RR x' y -> RR x y)
  : transL r t1 t2
.
Hint Constructors transL: core.

Lemma transD_transL r:
  transD RR (transL r) <2= transL (transD RR r).
Proof.
  intros. destruct PR, REL.
  econstructor; [|econstructor|]; try apply EQR.
  - eapply eqit_trans.
    + apply euttge_sub_eutt. eauto.
    + eauto.
  - reflexivity.
  - eauto.
  - auto_ctrans.
  - auto_ctrans.
  - auto_ctrans.
Qed.

Lemma transLleU: transL <3= transU RR.
Proof.
  intros. destruct PR. econstructor; eauto. reflexivity. auto_ctrans.
Qed.

Lemma transL_closed vclo r
      (MON: monotone2 vclo)
      (COMP: wcompatible2 (eqit_ RR true true vclo) (transD RR))
      (CLOV: forall r (CLOL: transL r <2= r), transL (vclo r) <2= vclo r)
      (CLOL: transL r <2= r)
      (CLOD: transD RR r <2= r):
  transL (gupaco2 (eqit_ RR true true vclo) (transD RR) r)
  <2= gupaco2 (eqit_ RR true true vclo) (transD RR) r.
Proof.
  pcofix CIH. intros t1 t2 [].
  apply gpaco2_dist in EQR; eauto with paco.
  destruct EQR; cycle 1.
  { gbase. apply rclo_transD in H. destruct H. eauto 7. }
  assert (REL: paco2 (eqit_ RR true true vclo) r t' t2).
  { eapply paco2_mon; eauto. intros.
    apply rclo_transD in PR. apply CLOD.
    eapply transD_mon; eauto. intros. destruct PR0; eauto.
  }
  clear H.

  punfold EQL. red in EQL. punfold REL. red in REL. genobs t1 ot1. genobs t' ot'.
  hinduction EQL before CIH; intros; subst.
  - remember (RetF r2) as ot. genobs t2 ot2.
    hinduction REL0 before CIH; intros; subst; try inv Heqot.
    + gstep. red. simpobs. eauto.
    + gclo. econstructor; auto_ctrans_eq.
      * rewrite (simpobs Heqot1). reflexivity.
      * rewrite (simpobs Heqot2), tau_euttge. reflexivity.
  - pclearbot. apply eqit_Tau_r in REL. rewrite Heqot' in REL, REL0. clear m2 Heqot'.
    genobs t' ot'. genobs t2 ot2.
    hinduction REL0 before CIH; intros; subst.
    + apply eqit_ret_gen in REL0.
      gclo. econstructor.
      * eapply eqit_trans; [rewrite (simpobs Heqot1); reflexivity|].
        eapply eqit_trans; [rewrite tau_euttge; reflexivity|].
        eauto.
      * rewrite (simpobs Heqot2). reflexivity.
      * gstep. econstructor. eauto.
      * auto_ctrans.
      * auto_ctrans.
    + gstep. red. simpobs. econstructor. gbase.
      destruct REL.
      * eapply CIH. econstructor; [|eauto using paco2_mon with paco|].
        -- eapply eqit_trans; [apply REL0|]. rewrite tau_eutt. reflexivity.
        -- auto_ctrans.
      * eapply CIH0. apply CLOL. econstructor; [|eauto|].
        -- eapply eqit_trans; [apply REL0|]. rewrite tau_eutt. reflexivity.
        -- auto_ctrans.
    + punfold REL0. red in REL0. simpl in *.
      remember (VisF e k1) as ot. genobs m1 ot2.
      hinduction REL0 before CIH; intros; try discriminate.
      * inv_Vis. pclearbot. gstep. red. do 2 (simpobs; econstructor; eauto). intros.
        eapply MON; [|intros; gbase; eapply CIH; eauto].
        eapply CLOV.
        { intros. destruct PR, EQR.
          econstructor; [|eauto|]; eauto using eqit_trans; auto_ctrans. }
        econstructor; eauto.
        eapply MON; eauto. intros.
        econstructor; try reflexivity; auto_ctrans.
        gfinal. destruct PR; eauto.
      * gclo; econstructor; auto_ctrans_eq; try reflexivity.
        rewrite (simpobs Heqot1), tau_euttge. reflexivity.
    + eapply IHREL0; try eapply eqit_trans; auto_ctrans_eq.
      rewrite <-itree_eta, tau_eutt. reflexivity.
    + gclo; econstructor; auto_ctrans_eq; try reflexivity.
      rewrite (simpobs Heqot2), tau_euttge. reflexivity.
  - remember (VisF e k2) as ot. genobs t2 ot2.
    hinduction REL0 before CIH; intros; subst; try discriminate.
    + inv_Vis. pclearbot. gstep. red. simpobs. econstructor; eauto. intros.
      eapply MON; [|intros; gbase; eapply CIH; eauto].
      eapply CLOV.
      { intros. destruct PR, EQR.
        econstructor; swap 1 2; eauto using eqit_trans; auto_ctrans. }
      econstructor; eauto.
      eapply MON; eauto. intros.
      econstructor; auto_ctrans_eq; try reflexivity.
      gfinal. destruct PR; eauto.
    + gclo; econstructor; auto_ctrans_eq; try reflexivity.
      rewrite (simpobs Heqot2), tau_euttge. reflexivity.
  - gclo; econstructor; auto_ctrans_eq; try reflexivity.
    rewrite (simpobs Heqot1), tau_euttge. reflexivity.
  - clear t' Heqot'. remember (TauF t2) as ot. genobs t0 ot0.
    hinduction REL before EQL; intros; subst; try inv Heqot; eauto; cycle 1.
    + gclo; econstructor; auto_ctrans_eq; try reflexivity.
      rewrite (simpobs Heqot0), tau_euttge. reflexivity.
    + destruct REL; cycle 1.
      * gbase. apply CLOL. econstructor; eauto.
        apply CLOD. econstructor; auto_ctrans_eq; try reflexivity.
        rewrite (simpobs Heqot0), tau_euttge. reflexivity.
      * eapply IHEQL; eauto.
        simpobs. econstructor; eauto.
        punfold H.
Qed.

Lemma euttVC_transL gH r:
  transL (euttVC RR gH r) <2= euttVC RR gH r.
Proof.
  intros. eapply transL_closed; eauto using transU_compose, transLleU, transDleU with paco.
Qed.

End EUTTG_Properties1.

Section EUTTG_Properties2.

Context {E : Type -> Type} {R1 R2 : Type} (RR : R1 -> R2 -> Prop).

Local Notation euttG := (@euttG E R1 R2 RR).

Lemma euttVC_transU gH r
      (CLOR: transU RR r <2= r):
  transU RR (euttVC RR gH r) <2= @euttVC E _ _ RR gH r.
Proof.
  intros. destruct PR.
  eapply euttVC_transL; eauto using transLleU, transDleU with paco.
  econstructor; eauto.
  eapply euttVC_flip. unfold flip.
  eapply euttVC_transL; eauto using transLleU, transDleU, transU_flip with paco.
  econstructor; eauto.
  apply euttVC_flip. eauto.
Qed.

Lemma euttG_transU_aux gH r
      (CLOR: transU RR r <2= r):
  transU RR (gupaco2 (eqit_ RR true true (euttVC RR gH)) (transD RR) r) <2=
  gupaco2 (@eqit_ E R1 R2 RR true true (euttVC RR gH)) (transD RR) r.
Proof.
  intros. destruct PR.
  eapply transL_closed; eauto using euttVC_transL, transLleU, transDleU with paco.
  econstructor; eauto.
  apply euttG_flip. unfold flip.
  eapply transL_closed; eauto using euttVC_transL, transLleU, transDleU, transU_flip with paco.
  econstructor; eauto.
  apply euttG_flip. eauto.
Qed.

Lemma euttVC_gen gH r:
  transU RR (gupaco2 (eqit_ RR true true (euttVC RR gH)) (transD RR) (transU RR (r \2/ gH)))
  <2= @euttVC E R1 R2 RR gH r.
Proof.
  intros. eapply euttG_transU_aux in PR; eauto using transU_compose.
  revert x0 x1 PR. pcofix CIH. intros.
  gunfold PR. apply rclo_transD in PR.
  gclo. eapply transD_mon; eauto. intros.
  destruct PR0; eauto with paco.
  gstep. red in H |- *. induction H; eauto.
  - econstructor. gbase. eapply CIH.
    eapply gupaco2_mon; eauto. intros.
    destruct PR0; eauto.
  - econstructor. intros. gbase. eapply CIH.
    red in REL. gupaco. eapply gupaco2_mon_gen; eauto with paco; intros.
    + eapply eqitF_mono; eauto with paco.
    + eapply euttG_transU_aux; eauto using transU_compose with paco.
      eapply transU_mon; eauto. intros.
      destruct PR1; [|eauto 7 with paco].
      eapply gupaco2_mon; eauto. intros.
      destruct PR1; eauto.
Qed.

Lemma euttG_gen rH rL gL gH:
  euttG rH rL (gL \2/ (transU RR rH \2/ rL)) gH <2= euttG rH rL gL gH.
Proof.
  intros. destruct PR. econstructor.
  eapply gpaco2_gen_guard. eauto.
Qed.

Lemma euttG_cofix_aux: forall rH rL gL gH x,
    (x <2= euttG rH rL (gL \2/ x) (gH \2/ x)) -> (x <2= euttG rH rL gL gH).
Proof.
  intros. apply euttG_gen.
  econstructor. revert x0 x1 PR. pcofix CIH.
  intros t1 t2 PR. apply H in PR. destruct PR as [IN]. revert t1 t2 IN.
  pcofix CIH. intros.
  apply gpaco2_dist in IN; eauto with paco.
  destruct IN; cycle 1.
  { apply rclo_transD in H0; eauto with paco.
    gclo. eapply transD_mon; eauto with paco.
  }
  assert (LEM: upaco2 (eqit_ RR true true (euttVC RR (gH \2/ x)))
                      (rclo2 (transD RR) ((gL \2/ x) \2/ (transU RR rH \2/ rL)))
               <2= gpaco2 (eqit_ RR true true (euttVC RR gH)) (transD RR) r0 r0).
  { intros m1 m2 [REL|REL].
    - gbase. apply CIH1.
      gpaco. gfinal. right.
      eapply paco2_mon; eauto. intros.
      apply rclo_transD in PR. gclo. eapply transD_mon; eauto. intros. gbase.
      repeat destruct PR0 as [PR0|PR0]; eauto.
    - apply rclo_transD in REL. gclo. eapply transD_mon; eauto. intros. gbase.
      repeat destruct PR as [PR|PR]; eauto.
  }

  punfold H0. gstep. red in H0 |- *.
  induction H0; eauto.
  red in REL. econstructor. intros.
  eapply gupaco2_mon; eauto. intros.
  apply transU_dist in PR. destruct PR; eauto using transU_mon.
  eapply transU_mon; eauto. intros; destruct PR; eauto with paco.
Qed.

End EUTTG_Properties2.

Section EUTTG_principles.

Context {E : Type -> Type} {R1 R2 : Type} (RR : R1 -> R2 -> Prop).

Local Notation euttG := (@euttG E R1 R2 RR).

(* Make new hypotheses *)

Lemma euttG_cofix rH rL gL gH x
      (OBG: forall gL' (INCL: gL <2= gL') (CIHL: x <2= gL') gH' (INCH: gH <2= gH') (CIHH: x <2= gH'), x <2= euttG rH rL gL' gH'):
    x <2= euttG rH rL gL gH.
Proof.
  eapply euttG_cofix_aux; intros.
  eapply OBG; eauto.
Qed.

Lemma euttG_accF rH rL gL gH X (f : X -> _) (g : X -> _)
    (OBJ: forall gL' (INCL: gL <2= gL') (CIHL: forall x : X, gL' (f x) (g x)) gH' (INCH: gH <2= gH') (CIHH: forall x : X, gH' (f x) (g x)), forall x : X, euttG rH rL gL' gH' (f x) (g x)):
    forall x : X, euttG rH rL gL gH (f x) (g x).
Proof.
  intros x.
  apply euttG_cofix with (x := fun a b => exists x, a = (f x) /\ b = (g x)); [ | eauto ].
  intros. destruct PR as [? [-> ->]]. apply OBJ; eauto.
Qed.

(* Process itrees *)

Lemma euttG_ret: forall rH rL gL gH v1 v2,
  RR v1 v2 -> euttG rH rL gL gH (Ret v1) (Ret v2).
Proof.
  econstructor. gstep. econstructor. eauto.
Qed.

Lemma euttG_bind: forall rH rL gL gH t1 t2,
  bindC (euttG rH rL gL gH) t1 t2 -> euttG rH rL gL gH t1 t2.
Proof.
  econstructor. guclo eqit_clo_bind.
  destruct H. econstructor; eauto.
  intros. edestruct REL; eauto.
Qed.

Lemma euttG_transD: forall rH rL gL gH t1 t2,
  transD RR (euttG rH rL gL gH) t1 t2 -> euttG rH rL gL gH t1 t2.
Proof.
  econstructor. guclo eqit_clo_trans.
  destruct H. econstructor; eauto.
  edestruct REL; eauto.
Qed.

(* Drop weak hypotheses for general rewriting *)

Lemma euttG_transU rH rL gL gH t1 t2:
  transU RR (euttG rH rH rH gH) t1 t2 -> euttG rH rL gL gH t1 t2.
Proof.
  intros. apply euttG_gen.
  cut (gupaco2 (eqit_ RR true true (euttVC RR gH)) (transD RR) (transU RR rH) t1 t2).
  { intros. econstructor. eapply gpaco2_mon; eauto. }
  eapply euttG_transU_aux; eauto using transU_compose.
  eapply transU_mon; eauto. intros. destruct PR.
  eapply gpaco2_mon; eauto; intros;
    repeat destruct PR as [PR|PR]; eauto using transU_id.
Qed.

Lemma euttG_drop rH rL gL gH t1 t2:
  euttG rH rH rH gH t1 t2 -> euttG rH rL gL gH t1 t2.
Proof.
  intros. apply euttG_gen. destruct H. econstructor.
  eapply gpaco2_mon; intros; eauto; [destruct PR|]; eauto using transU_id.
Qed.

(* Make a weakly guarded progress *)

Lemma euttG_tau: forall rH rL gL gH t1 t2,
  euttG rH gL gL gH t1 t2 -> euttG rH rL gL gH (Tau t1) (Tau t2).
Proof.
  intros. apply euttG_gen. destruct H. econstructor.
  gstep. econstructor.
  eapply gpaco2_mon; eauto; intros; repeat destruct PR as [PR|PR]; eauto.
Qed.

(* Make a strongly guarded progress *)

Lemma euttG_vis: forall rH rL gL gH u (e: E u) k1 k2,
  (forall v, euttG gH gH gH gH (k1 v) (k2 v)) -> euttG rH rL gL gH (Vis e k1) (Vis e k2).
Proof.
  econstructor. gstep. econstructor. intros.
  specialize (H v). destruct H.
  apply euttVC_gen. econstructor; auto_ctrans_eq; try reflexivity.
  eapply gpaco2_mon_gen; eauto; intros; repeat destruct PR as [PR|PR];
    eauto using gpaco2_clo, transDleU, transU_mon with paco.
Qed.

Lemma euttG_vis_gen rH rL gL gH u1 (e1: E u1) u2 (e2 : E u2) k1 k2 (p : u1 = u2)
  : eqeq E p e1 e2 -> pweqeq (euttG gH gH gH gH) p k1 k2 ->
    euttG rH rL gL gH (Vis e1 k1) (Vis e2 k2).
Proof.
  econstructor. gstep. apply (eqitF_VisF_gen p); auto. destruct p; cbn in *; intros.
  specialize (H0 x). destruct H0.
  apply euttVC_gen. econstructor; auto_ctrans_eq; try reflexivity.
  eapply gpaco2_mon_gen; eauto; intros; repeat destruct PR as [PR|PR];
    eauto using gpaco2_clo, transDleU, transU_mon with paco.
Qed.

(* Use available hypotheses *)

Lemma euttG_base: forall rH rL gL gH t1 t2,
  rH t1 t2 \/ rL t1 t2 -> euttG rH rL gL gH t1 t2.
Proof.
  intros. econstructor. gbase.
  destruct H; eauto using transU_id.
Qed.

(**
   Correctness
 **)

Lemma euttG_le_eutt:
  euttG bot2 bot2 bot2 bot2 <2= eutt RR.
Proof.
  intros. destruct PR.
  assert(paco2 (eqit_ RR true true (euttVC RR bot2)) bot2 x0 x1).
  { eapply gpaco2_init; eauto with paco.
    eapply gpaco2_mon; eauto; intros;
      repeat destruct PR as [PR|PR]; destruct PR; contradiction.
  }
  clear IN.
  revert x0 x1 H. pcofix CIH. intros.
  punfold H. pstep. unfold_eqit.
  induction H; pclearbot; eauto.
  econstructor; intros. specialize (REL v).
  right. apply CIH.
  ginit. gupaco. eapply gupaco2_mon_gen; eauto with paco; intros.
  - eapply eqitF_mono; eauto with paco.
  - apply euttG_transU_aux.
    { intros. destruct PR0; contradiction. }
    eapply transU_mon; eauto. intros.
    pclearbot. gfinal. eauto.
Qed.

Lemma eutt_le_euttG rH rL gL gH:
  eutt RR <2= euttG rH rL gL gH.
Proof.
  intros. econstructor. econstructor. apply rclo2_base. left.
  eapply paco2_mon_bot; eauto; intros.
  eapply eqitF_mono; eauto with paco.
Qed.

End EUTTG_principles.

Ltac apply_paco_acc CIH unpack_goal unpack_hyp :=
  apply euttG_accF;
  let gL' := fresh "gL'" in
  let INCL := fresh "INCL" in
  let CIHL := fresh CIH "L" in
  let gH' := fresh "gH'" in
  let INCH := fresh "INCH" in
  let CIHH := fresh CIH "H" in
  intros gL' INCL CIHL gH' INCH CIHH;
  unpack_goal tt;
  unpack_hyp CIHL;
  unpack_hyp CIHH.

Ltac ecofix CIH := pcofix_with ltac:(apply_paco_acc CIH).

Ltac einit := repeat red; under_forall ltac:(eapply euttG_le_eutt; eauto with paco).
Ltac efinal := repeat red; under_forall ltac:(eapply eutt_le_euttG; eauto with paco).
Ltac ebase := repeat red; under_forall ltac:(eapply euttG_base; eauto with paco).
Ltac eret := repeat red; under_forall ltac:(eapply euttG_ret; eauto with paco).
Ltac etau := repeat red; under_forall ltac:(eapply euttG_tau; eauto with paco).
Ltac evis := repeat red; under_forall ltac:(eapply euttG_vis; eauto with paco).
Ltac estep := first [eret|etau|evis].
Ltac ebind := repeat red; under_forall ltac:(eapply euttG_bind; eauto with paco).
Ltac edrop := repeat red; under_forall ltac:(eapply euttG_drop; eauto with paco).

Global Hint Resolve euttG_ret : paco.
Global Hint Resolve euttG_tau : paco.
Global Hint Resolve euttG_vis : paco.
Global Hint Resolve euttG_base : paco.
Global Hint Resolve euttG_le_eutt: paco.

Global Instance euttG_reflexive {E R} rH rL gL gH:
  Reflexive (@euttG E R R eq rH rL gL gH).
Proof.
  red; intros. efinal. reflexivity.
Qed.

Global Instance euttG_cong_eutt {E R1 R2 RR} rH gH:
  Proper (eutt eq ==> eutt eq ==> flip impl)
         (@euttG E R1 R2 RR rH rH rH gH).
Proof.
  repeat intro. eapply euttG_transU. econstructor; auto_ctrans_eq; eauto.
Qed.

Global Instance euttG_cong_euttge {E R1 R2 RR} rH rL gL gH:
  Proper (euttge eq ==> euttge eq ==> flip impl)
         (@euttG E R1 R2 RR rH rL gL gH).
Proof.
  repeat intro. eapply euttG_transD. econstructor; auto_ctrans_eq; eauto.
Qed.

Global Instance euttG_cong_eq {E R1 R2 RR} rH rL gL gH:
  Proper (eq_itree eq ==> eq_itree eq ==> flip impl)
         (@euttG E R1 R2 RR rH rL gL gH).
Proof.
  repeat intro. eapply euttG_cong_euttge; eauto; apply eq_sub_euttge; eauto.
Qed.

Global Instance eutt_cong_eutt {E R1 R2 RR}:
  Proper (eutt eq ==> eutt eq ==> flip impl)
         (@eqit E R1 R2 RR true true).
Proof.
  einit. intros. rewrite H0, H1. efinal.
Qed.

Global Instance eutt_cong_euttge {E R1 R2 RR}:
  Proper (euttge eq ==> euttge eq ==> flip impl)
         (@eqit E R1 R2 RR true true).
Proof.
  einit. intros. rewrite H0, H1. efinal.
Qed.

Global Instance eutt_cong_eq {E R1 R2 RR}:
  Proper (eq_itree eq ==> eq_itree eq ==> flip impl)
         (@eqit E R1 R2 RR true true).
Proof.
  einit. intros. rewrite H0, H1. efinal.
Qed.

Global Instance eutt_cong_eutt' {E R1 R2 RR} :
  Proper (eutt eq ==> eutt eq ==> flip impl) (@eutt E R1 R2 RR).
Proof.
  apply eutt_cong_eutt.
Qed.

(* Specialization of [eutt_clo_bind] to the recurrent case where [UU := eq]
   in order to avoid having to provide the relation manually everytime *)
Lemma eutt_eq_bind : forall E R1 R2 RR U (t: itree E U) (k1: U -> itree E R1) (k2: U -> itree E R2),
    (forall u, eutt RR (k1 u) (k2 u)) -> eutt RR (ITree.bind t k1) (ITree.bind t k2).
Proof.
  intros.
  apply eutt_clo_bind with (UU := Logic.eq); [reflexivity |].
  intros ? ? ->; apply H.
Qed.

(* Exposing a version specialized to [eutt] so that users don't have to know about [eqit] *)
Lemma eutt_Ret :
  forall E (R1 R2 : Type) (RR : R1 -> R2 -> Prop) r1 r2, RR r1 r2 <-> eutt (E := E) RR (Ret r1) (Ret r2).
Proof.
  intros; apply eqit_Ret.
Qed.

Lemma eq_itree_conj {E} {R S} {RS RS'} :
  forall (t : itree E R) (s : itree E S),
    eq_itree RS t s ->
    eq_itree RS' t s ->
    eq_itree (RS /2\ RS') t s.
Proof.
  repeat red.
  ginit. gcofix CIH. intros * EQ EQ'.
  (* einit. ecofix CIH. intros * EQ EQ'. *)
  rewrite itree_eta, (itree_eta s).
  punfold EQ; punfold EQ'; red in EQ; red in EQ'.
  genobs t ot; genobs s os.
  hinduction EQ before CIH; subst; intros; pclearbot; simpl.

  - gstep.
    inv EQ'; auto. constructor. auto.
  - gstep. constructor. gbase.
    eapply CIH; inv EQ'; try inv CHECK; auto. pclearbot. auto.
  - assert (EE := eqitF_inv_VisF _ _ _ _ _ EQ'); pclearbot.
    gstep. constructor. intros. gbase. apply CIH; eauto.
  - inv CHECK.
  - inv CHECK.
Qed.

(* [eutt] can be thought as the elementary block of a relational program logic.
   The following few lemmas give elementary logical rules to compose proofs.
 *)
Lemma eutt_conj {E} {R S} {RS RS'} :
  forall (t : itree E R) (s : itree E S),
    eutt RS  t s ->
    eutt RS' t s ->
    eutt (RS /2\ RS') t s.
Proof.
  repeat red.
  einit. ecofix CIH. intros * EQ EQ'.
  rewrite itree_eta, (itree_eta s).
  punfold EQ; punfold EQ'; red in EQ; red in EQ'.
  genobs t ot; genobs s os.
  hinduction EQ before CIHH; subst; intros; pclearbot; simpl.

  - estep; split; auto.
    inv EQ'; auto.
  - estep; ebase; right; eapply CIHL; eauto.
    rewrite <- tau_eutt.
    rewrite <- (tau_eutt m2); auto.
  - assert (EE := eqitF_inv_VisF _ _ _ _ _ EQ'); pclearbot.
    eapply euttG_vis; ebase; left; apply CIHH; auto.
  - eapply fold_eqitF in EQ'; eauto.
    assert (t ≈ Tau t1) by (rewrite itree_eta, <- Heqot; reflexivity).
    rewrite H in EQ'.
    apply eqit_inv_Tau_l in EQ'.
    subst; specialize (IHEQ _ _ eq_refl eq_refl).
    punfold EQ'; red in EQ'.
    specialize (IHEQ EQ').
    rewrite eqit_Tau_l; [|reflexivity].
    rewrite (itree_eta t1).
    eapply IHEQ.
  - subst; cbn.
    rewrite tau_euttge.
    rewrite (itree_eta t2); eapply IHEQ; eauto.
    eapply fold_eqitF in EQ'; eauto.
    assert (s ≈ Tau t2).
    rewrite (itree_eta s), <- Heqos; reflexivity.
    rewrite tau_eutt in H.
    assert (eutt RS' t t2).
    rewrite <- H; auto.
    punfold H0.
Qed.

Lemma eutt_disj_l {E} {R S} {RS RS'} :
  forall (t : itree E R) (s : itree E S),
    eutt RS t s ->
    eutt (RS \2/ RS') t s.
Proof.
  intros.
  eapply eqit_mon with (RR := RS); eauto.
Qed.

Lemma eutt_disj_r {E} {R S} {RS RS'} :
  forall (t : itree E R) (s : itree E S),
    eutt RS' t s ->
    eutt (RS \2/ RS') t s.
Proof.
  intros.
  eapply eqit_mon with (RR := RS'); eauto.
Qed.

Lemma eutt_equiv {E} {R S} {RS RS'} :
  forall (t : itree E R) (s : itree E S),
    (HeterogeneousRelations.eq_rel RS RS') ->
    eutt RS t s <-> eutt RS' t s.
Proof.
  intros * EQ; split; intros EUTT; eapply eqit_mon; try apply EUTT; eauto.
  all:apply EQ.
Qed.

(* Rewriting equivalent simulation relations under [eq_itree] and [eutt] *)
Global Instance eq_itree_Proper_R {E : Type -> Type} {R1 R2:Type}
  : Proper ((@HeterogeneousRelations.eq_rel R1 R2) ==> Logic.eq ==> Logic.eq ==> iff) (@eq_itree E R1 R2).
Proof.
  repeat intro; subst.
  unfold eq_itree; rewrite H; reflexivity.
Qed.

Global Instance eutt_Proper_R {E : Type -> Type} {R1 R2:Type}
  : Proper  ((@HeterogeneousRelations.eq_rel R1 R2) ==> eq ==> eq ==> iff) (@eutt E R1 R2).
Proof.
  repeat intro; subst.
  unfold eutt; rewrite H; reflexivity.
Qed.


(* This module only serves to demonstrate that defining the typing relation     *)
(* with stronger requirements in terms of context validity and well-formedness  *)
(* of type expressions is unnecessary and yields an equivalent notion.          *)
Require Import Logic.Class.Eq.

Require Import Logic.STLC.Valid.
Require Import Logic.STLC.Syntax.
Require Import Logic.STLC.IsType.
Require Import Logic.STLC.Typing.
Require Import Logic.STLC.Context.

Inductive Judgement2 (b v:Type) (eq:Eq v): Context -> Typing -> Prop :=
| JAnn2 : forall (G:Context) (e:Exp b v) (Ty:T b),
    Valid G                                     ->  (* superfluous              *)
    G :> Ty                                     ->  (* superfluous              *)
    Judgement2 b v eq G (e >: Ty)               ->
    Judgement2 b v eq G ((e :: Ty) >: Ty)
| JVar2 : forall (G:Context) (x:v) (Ty:T b),
    Valid G                                     ->
    G :> Ty                                     ->  (* superfluous              *)
    G :>> x ::: Ty                              ->
    Judgement2 b v eq G (`x >: Ty)
| JApp2 : forall (G:Context) (e1 e2:Exp b v) (Ty Ty':T b),
    Valid G                                     ->  (* superfluous              *)
    G :> Ty                                     ->  (* superfluous              *)
    G :> Ty'                                    ->  (* superfluous              *)
    Judgement2 b v eq G (e1 >: Ty :-> Ty')      ->
    Judgement2 b v eq G (e2 >: Ty)              ->
    Judgement2 b v eq G (e1 $ e2 >: Ty')
| JLam2 : forall (G:Context) (x:v) (e:Exp b v) (Ty Ty':T b),
    Valid G                                     ->
    G :> Ty                                     ->
    Judgement2 b v eq (G;x ::: Ty) (e >: Ty')   ->
    Judgement2 b v eq G ((\x ~> e) >: Ty :-> Ty')
.

Arguments Judgement2 {b} {v} {eq}.
Arguments JAnn2      {b} {v} {eq}.
Arguments JVar2      {b} {v} {eq}.
Arguments JApp2      {b} {v} {eq}.
Arguments JLam2      {b} {v} {eq}.

(* Building a proof of Judgment2 requires more evidence that for building a     *)
(* proof of Judgment. Hence expecting the following implication to hold.        *)
Lemma Judgement2Judgement :
    forall (b v:Type) (eq:Eq v) (G:Context) (e:Exp b v) (Ty:T b),
        Judgement2 G (e >: Ty) -> G :- e >: Ty.
Proof.
    intros b v eq G e Ty H1. remember (e >: Ty) as k eqn:E. revert e Ty E.
    induction H1 as
        [ G e Ty H2 H3 H4 IH
        | G x Ty H2 H3 H4
        | G e1 e2 Ty Ty' H2 H3 H4 H5 IH1 H6 IH2
        | G x e Ty Ty' H2 H3 H4 IH
        ]; intros e' Sy H7; inversion H7; subst; clear H7.
    - apply JAnn. apply IH with e Sy. reflexivity.
    - apply JVar; assumption.
    - apply JApp with Ty.
        + apply IH1 with e1 (Ty :-> Sy). reflexivity.
        + apply IH2 with e2 Ty. reflexivity.
    - apply JLam; try assumption. apply IH with e Ty'. reflexivity.
Qed.

(* However, we know that a Judgement cannot hold unless the context is valid    *)
(* and the type expression is well-formed. So the following should hold.        *)
 Lemma JudgementJudgement2 :
    forall (b v:Type) (eq:Eq v) (G:Context) (e:Exp b v) (Ty:T b),
        G :- e >: Ty -> Judgement2 G (e >: Ty).
Proof.
    intros b v eq G e Ty H1. remember (e >: Ty) as k eqn:E. revert e Ty E.
    induction H1 as
        [ G e Ty H2 IH
        | G x Ty H2 H3
        | G e1 e2 Ty Ty' H2 IH1 H3 IH2
        | G x e Ty Ty' H2 H3 H4 IH
        ]; intros e' Sy H7; inversion H7; subst; clear H7.
    - apply JAnn2.
        + apply TypedIsValid with eq e Sy. assumption.
        + apply TypedIsType with eq e. assumption.
        + apply IH with e Sy. reflexivity.
    - apply JVar2; try assumption. apply ValidIsType with eq x; assumption.
    - apply JApp2 with Ty.
        + apply TypedIsValid with eq e2 Ty. assumption.
        + apply TypedIsType with eq e2. assumption.
        + apply IsTypeRevR with Ty. apply TypedIsType with eq e1. assumption.
        + apply IH1 with e1 (Ty :-> Sy). reflexivity.
        + apply IH2 with e2 Ty. reflexivity.
    - apply JLam2; try assumption. apply IH with e Ty'. reflexivity.
Qed.

(* This vindicates our streamlined definition of the Judgement predicate.       *)
Theorem JudgementJudgement2Same:
    forall (b v:Type) (eq:Eq v) (G:Context) (e:Exp b v) (Ty:T b),
        G :- e >: Ty <-> Judgement2 G (e >: Ty).
Proof.
    intros b v eq G e Ty. split; intros H1.
    - apply JudgementJudgement2. assumption.
    - apply Judgement2Judgement. assumption.
Qed.


Require Import core core_axioms unscoped.
Import UnscopedNotations.

#[ local ]
 Open Scope subst_scope.

(** Eta laws. *)
Lemma scons_eta_id {n : nat} : var_zero .: shift = id :> (nat -> nat).
Proof. fext. intros [|x]; reflexivity. Qed.

Lemma scons_eta {T} (f : nat -> T) :
  f var_zero .: shift >> f = f.
Proof. fext. intros [|x]; reflexivity. Qed.

Lemma scons_comp (T: Type) U (s: T) (sigma: nat -> T) (tau: T -> U ) :
  (s .: sigma) >> tau = scons (tau s) (sigma >> tau) .
Proof.
  fext. intros [|x]; reflexivity.
Qed.