(* generated by Ott 0.27, locally-nameless lngen from: DOT.ott *)
Require Import Metalib.Metatheory.
(** syntax *)
Definition termvar := var.
Definition trmlabel := atom.
Definition typlabel := atom.

Inductive varref : Set :=
 | var_termvar_b (_:nat)
 | var_termvar_f (x:termvar).

Inductive typ : Set :=
 | typ_all (T1:typ) (T2:typ)
 | typ_bnd (T:typ)
 | typ_dec (dec5:dec)
 | typ_sel (v:varref) (A:typlabel)
 | typ_and (T1:typ) (T2:typ)
 | typ_top : typ
 | typ_bot : typ
with dec : Set :=
 | dec_trm (a:trmlabel) (T:typ)
 | dec_typ (A:typlabel) (T1:typ) (T2:typ).

Inductive trm : Set :=
 | trm_var (v:varref)
 | trm_val (val5:val)
 | trm_sel (v:varref) (a:trmlabel)
 | trm_app (v1:varref) (v2:varref)
 | trm_let (t1:trm) (t2:trm)
with val : Set :=
 | val_new (T:typ) (defs5:defs)
 | val_lambda (T:typ) (t:trm)
with defs : Set :=
 | defs_nil : defs
 | defs_cons (d:def) (defs5:defs)
with def : Set :=
 | def_trm (a:trmlabel) (t:trm)
 | def_typ (A:typlabel) (T:typ).

Definition ctx : Set := list (atom*typ).

Definition stack : Set := list (atom*trm).

(* EXPERIMENTAL *)
(** auxiliary functions on the new list types *)
(** library functions *)
(** subrules *)
(** arities *)
(** opening up abstractions *)
Definition open_varref_wrt_varref_rec (k:nat) (v5:varref) (v_6:varref) : varref :=
  match v_6 with
  | (var_termvar_b nat) =>
      match lt_eq_lt_dec nat k with
        | inleft (left _) => var_termvar_b nat
        | inleft (right _) => v5
        | inright _ => var_termvar_b (nat - 1)
      end
  | (var_termvar_f x) => var_termvar_f x
end.

Fixpoint open_dec_wrt_varref_rec (k:nat) (v5:varref) (dec5:dec) : dec :=
  match dec5 with
  | (dec_trm a T) => dec_trm a (open_typ_wrt_varref_rec k v5 T)
  | (dec_typ A T1 T2) => dec_typ A (open_typ_wrt_varref_rec k v5 T1) (open_typ_wrt_varref_rec k v5 T2)
end
with open_typ_wrt_varref_rec (k:nat) (v5:varref) (T_5:typ) {struct T_5}: typ :=
  match T_5 with
  | (typ_all T1 T2) => typ_all (open_typ_wrt_varref_rec k v5 T1) (open_typ_wrt_varref_rec (S k) v5 T2)
  | (typ_bnd T) => typ_bnd (open_typ_wrt_varref_rec (S k) v5 T)
  | (typ_dec dec5) => typ_dec (open_dec_wrt_varref_rec k v5 dec5)
  | (typ_sel v A) => typ_sel (open_varref_wrt_varref_rec k v5 v) A
  | (typ_and T1 T2) => typ_and (open_typ_wrt_varref_rec k v5 T1) (open_typ_wrt_varref_rec k v5 T2)
  | typ_top => typ_top
  | typ_bot => typ_bot
end.

Fixpoint open_def_wrt_varref_rec (k:nat) (v5:varref) (d5:def) : def :=
  match d5 with
  | (def_trm a t) => def_trm a (open_trm_wrt_varref_rec k v5 t)
  | (def_typ A T) => def_typ A (open_typ_wrt_varref_rec k v5 T)
end
with open_defs_wrt_varref_rec (k:nat) (v5:varref) (defs_6:defs) {struct defs_6}: defs :=
  match defs_6 with
  | defs_nil => defs_nil
  | (defs_cons d defs5) => defs_cons (open_def_wrt_varref_rec k v5 d) (open_defs_wrt_varref_rec k v5 defs5)
end
with open_val_wrt_varref_rec (k:nat) (v5:varref) (val5:val) : val :=
  match val5 with
  | (val_new T defs5) => val_new (open_typ_wrt_varref_rec k v5 T) (open_defs_wrt_varref_rec (S k) v5 defs5)
  | (val_lambda T t) => val_lambda (open_typ_wrt_varref_rec k v5 T) (open_trm_wrt_varref_rec (S k) v5 t)
end
with open_trm_wrt_varref_rec (k:nat) (v_5:varref) (t_5:trm) {struct t_5}: trm :=
  match t_5 with
  | (trm_var v) => trm_var (open_varref_wrt_varref_rec k v_5 v)
  | (trm_val val5) => trm_val (open_val_wrt_varref_rec k v_5 val5)
  | (trm_sel v a) => trm_sel (open_varref_wrt_varref_rec k v_5 v) a
  | (trm_app v1 v2) => trm_app (open_varref_wrt_varref_rec k v_5 v1) (open_varref_wrt_varref_rec k v_5 v2)
  | (trm_let t1 t2) => trm_let (open_trm_wrt_varref_rec k v_5 t1) (open_trm_wrt_varref_rec (S k) v_5 t2)
end.

Definition open_def_wrt_varref v5 d5 := open_def_wrt_varref_rec 0 d5 v5.

Definition open_val_wrt_varref v5 val5 := open_val_wrt_varref_rec 0 val5 v5.

Definition open_defs_wrt_varref v5 defs_6 := open_defs_wrt_varref_rec 0 defs_6 v5.

Definition open_dec_wrt_varref v5 dec5 := open_dec_wrt_varref_rec 0 dec5 v5.

Definition open_varref_wrt_varref v5 v_6 := open_varref_wrt_varref_rec 0 v_6 v5.

Definition open_typ_wrt_varref v5 T_5 := open_typ_wrt_varref_rec 0 T_5 v5.

Definition open_trm_wrt_varref v_5 t_5 := open_trm_wrt_varref_rec 0 t_5 v_5.

(** terms are locally-closed pre-terms *)
(** definitions *)

(* defns LC_varref *)
Inductive lc_varref : varref -> Prop :=    (* defn lc_varref *)
 | lc_var_termvar_f : forall (x:termvar),
     (lc_varref (var_termvar_f x)).

(* defns LC_dec_typ *)
Inductive lc_dec : dec -> Prop :=    (* defn lc_dec *)
 | lc_dec_trm : forall (a:trmlabel) (T:typ),
     (lc_typ T) ->
     (lc_dec (dec_trm a T))
 | lc_dec_typ : forall (A:typlabel) (T1 T2:typ),
     (lc_typ T1) ->
     (lc_typ T2) ->
     (lc_dec (dec_typ A T1 T2))
with lc_typ : typ -> Prop :=    (* defn lc_typ *)
 | lc_typ_all : forall (T1 T2:typ),
     (lc_typ T1) ->
      ( forall x , lc_typ  ( open_typ_wrt_varref T2 (var_termvar_f x) )  )  ->
     (lc_typ (typ_all T1 T2))
 | lc_typ_bnd : forall (T:typ),
      ( forall x , lc_typ  ( open_typ_wrt_varref T (var_termvar_f x) )  )  ->
     (lc_typ (typ_bnd T))
 | lc_typ_dec : forall (dec5:dec),
     (lc_dec dec5) ->
     (lc_typ (typ_dec dec5))
 | lc_typ_sel : forall (v:varref) (A:typlabel),
     (lc_varref v) ->
     (lc_typ (typ_sel v A))
 | lc_typ_and : forall (T1 T2:typ),
     (lc_typ T1) ->
     (lc_typ T2) ->
     (lc_typ (typ_and T1 T2))
 | lc_typ_top :
     (lc_typ typ_top)
 | lc_typ_bot :
     (lc_typ typ_bot).

(* defns LC_def_defs_val_trm *)
Inductive lc_def : def -> Prop :=    (* defn lc_def *)
 | lc_def_trm : forall (a:trmlabel) (t:trm),
     (lc_trm t) ->
     (lc_def (def_trm a t))
 | lc_def_typ : forall (A:typlabel) (T:typ),
     (lc_typ T) ->
     (lc_def (def_typ A T))
with lc_defs : defs -> Prop :=    (* defn lc_defs *)
 | lc_defs_nil :
     (lc_defs defs_nil)
 | lc_defs_cons : forall (d:def) (defs5:defs),
     (lc_def d) ->
     (lc_defs defs5) ->
     (lc_defs (defs_cons d defs5))
with lc_val : val -> Prop :=    (* defn lc_val *)
 | lc_val_new : forall (T:typ) (defs5:defs),
     (lc_typ T) ->
      ( forall x , lc_defs  ( open_defs_wrt_varref defs5 (var_termvar_f x) )  )  ->
     (lc_val (val_new T defs5))
 | lc_val_lambda : forall (T:typ) (t:trm),
     (lc_typ T) ->
      ( forall x , lc_trm  ( open_trm_wrt_varref t (var_termvar_f x) )  )  ->
     (lc_val (val_lambda T t))
with lc_trm : trm -> Prop :=    (* defn lc_trm *)
 | lc_trm_var : forall (v:varref),
     (lc_varref v) ->
     (lc_trm (trm_var v))
 | lc_trm_val : forall (val5:val),
     (lc_val val5) ->
     (lc_trm (trm_val val5))
 | lc_trm_sel : forall (v:varref) (a:trmlabel),
     (lc_varref v) ->
     (lc_trm (trm_sel v a))
 | lc_trm_app : forall (v1 v2:varref),
     (lc_varref v1) ->
     (lc_varref v2) ->
     (lc_trm (trm_app v1 v2))
 | lc_trm_let : forall (t1 t2:trm),
     (lc_trm t1) ->
      ( forall x , lc_trm  ( open_trm_wrt_varref t2 (var_termvar_f x) )  )  ->
     (lc_trm (trm_let t1 t2)).
(** free variables *)
Definition fv_varref (v5:varref) : vars :=
  match v5 with
  | (var_termvar_b nat) => {}
  | (var_termvar_f x) => {{x}}
end.

Fixpoint fv_dec (dec5:dec) : vars :=
  match dec5 with
  | (dec_trm a T) => (fv_typ T)
  | (dec_typ A T1 T2) => (fv_typ T1) \u (fv_typ T2)
end
with fv_typ (T_5:typ) : vars :=
  match T_5 with
  | (typ_all T1 T2) => (fv_typ T1) \u (fv_typ T2)
  | (typ_bnd T) => (fv_typ T)
  | (typ_dec dec5) => (fv_dec dec5)
  | (typ_sel v A) => (fv_varref v)
  | (typ_and T1 T2) => (fv_typ T1) \u (fv_typ T2)
  | typ_top => {}
  | typ_bot => {}
end.

Fixpoint fv_def (d5:def) : vars :=
  match d5 with
  | (def_trm a t) => (fv_trm t)
  | (def_typ A T) => (fv_typ T)
end
with fv_defs (defs_6:defs) : vars :=
  match defs_6 with
  | defs_nil => {}
  | (defs_cons d defs5) => (fv_def d) \u (fv_defs defs5)
end
with fv_val (val5:val) : vars :=
  match val5 with
  | (val_new T defs5) => (fv_typ T) \u (fv_defs defs5)
  | (val_lambda T t) => (fv_typ T) \u (fv_trm t)
end
with fv_trm (t_5:trm) : vars :=
  match t_5 with
  | (trm_var v) => (fv_varref v)
  | (trm_val val5) => (fv_val val5)
  | (trm_sel v a) => (fv_varref v)
  | (trm_app v1 v2) => (fv_varref v1) \u (fv_varref v2)
  | (trm_let t1 t2) => (fv_trm t1) \u (fv_trm t2)
end.

(** substitutions *)
Definition subst_varref (v5:varref) (x5:termvar) (v_6:varref) : varref :=
  match v_6 with
  | (var_termvar_b nat) => var_termvar_b nat
  | (var_termvar_f x) => (if eq_var x x5 then v5 else (var_termvar_f x))
end.

Fixpoint subst_dec (v5:varref) (x5:termvar) (dec5:dec) {struct dec5} : dec :=
  match dec5 with
  | (dec_trm a T) => dec_trm a (subst_typ v5 x5 T)
  | (dec_typ A T1 T2) => dec_typ A (subst_typ v5 x5 T1) (subst_typ v5 x5 T2)
end
with subst_typ (v5:varref) (x5:termvar) (T_5:typ) {struct T_5} : typ :=
  match T_5 with
  | (typ_all T1 T2) => typ_all (subst_typ v5 x5 T1) (subst_typ v5 x5 T2)
  | (typ_bnd T) => typ_bnd (subst_typ v5 x5 T)
  | (typ_dec dec5) => typ_dec (subst_dec v5 x5 dec5)
  | (typ_sel v A) => typ_sel (subst_varref v5 x5 v) A
  | (typ_and T1 T2) => typ_and (subst_typ v5 x5 T1) (subst_typ v5 x5 T2)
  | typ_top => typ_top
  | typ_bot => typ_bot
end.

Fixpoint subst_def (v5:varref) (x5:termvar) (d5:def) {struct d5} : def :=
  match d5 with
  | (def_trm a t) => def_trm a (subst_trm v5 x5 t)
  | (def_typ A T) => def_typ A (subst_typ v5 x5 T)
end
with subst_defs (v5:varref) (x5:termvar) (defs_6:defs) {struct defs_6} : defs :=
  match defs_6 with
  | defs_nil => defs_nil
  | (defs_cons d defs5) => defs_cons (subst_def v5 x5 d) (subst_defs v5 x5 defs5)
end
with subst_val (v5:varref) (x5:termvar) (val5:val) {struct val5} : val :=
  match val5 with
  | (val_new T defs5) => val_new (subst_typ v5 x5 T) (subst_defs v5 x5 defs5)
  | (val_lambda T t) => val_lambda (subst_typ v5 x5 T) (subst_trm v5 x5 t)
end
with subst_trm (v_5:varref) (x5:termvar) (t_5:trm) {struct t_5} : trm :=
  match t_5 with
  | (trm_var v) => trm_var (subst_varref v_5 x5 v)
  | (trm_val val5) => trm_val (subst_val v_5 x5 val5)
  | (trm_sel v a) => trm_sel (subst_varref v_5 x5 v) a
  | (trm_app v1 v2) => trm_app (subst_varref v_5 x5 v1) (subst_varref v_5 x5 v2)
  | (trm_let t1 t2) => trm_let (subst_trm v_5 x5 t1) (subst_trm v_5 x5 t2)
end.

Fixpoint defs_has (ds: defs) (d: def) : Prop :=
  match ds with
  | defs_nil => False
  | defs_cons d' ds' =>
      d' = d \/ defs_has ds' d
  end.

Fixpoint type_labels (T: typ) : atoms :=
  match T with
  | typ_dec (dec_trm a _) => singleton a
  | typ_dec (dec_typ A _ _) => singleton A
  | typ_and T1 T2 => type_labels T1 \u type_labels T2
  | _ => empty
  end.

(** definitions *)

(* defns Typing *)
Inductive ty_trm : ctx -> trm -> typ -> Prop :=    (* defn ty_trm *)
 | ty_var : forall (G:ctx) (x:termvar) (T:typ),
      (binds ( x ) ( T ) ( G ))  ->
     ty_trm G (trm_var (var_termvar_f x)) T
 | ty_all_intro : forall (L:vars) (G:ctx) (T1:typ) (t:trm) (T2:typ),
      ( forall x , x \notin  L  -> ty_trm  ( x ~ T1  ++  G )   ( open_trm_wrt_varref t (var_termvar_f x) )   ( open_typ_wrt_varref T2 (var_termvar_f x) )  )  ->
     ty_trm G (trm_val (val_lambda T1 t)) (typ_all T1 T2)
 | ty_all_elim : forall (G:ctx) (x y:termvar) (T2 T1:typ),
     ty_trm G (trm_var (var_termvar_f x)) (typ_all T1 T2) ->
     ty_trm G (trm_var (var_termvar_f y)) T1 ->
     ty_trm G (trm_app (var_termvar_f x) (var_termvar_f y))  (open_typ_wrt_varref  T2   (var_termvar_f y) )
 | ty_new_intro : forall (L:vars) (G:ctx) (T:typ) (defs5:defs),
      ( forall x , x \notin  L  -> ty_defs  ( x ~  ( open_typ_wrt_varref T (var_termvar_f x) )   ++  G )   ( open_defs_wrt_varref defs5 (var_termvar_f x) )   ( open_typ_wrt_varref T (var_termvar_f x) )  )  ->
      ( forall x , x \notin  L  -> ty_trm G (trm_val (val_new  ( open_typ_wrt_varref T (var_termvar_f x) )  defs5)) (typ_bnd T) )
 | ty_new_elim : forall (G:ctx) (x:termvar) (a:trmlabel) (T:typ),
     ty_trm G (trm_var (var_termvar_f x)) (typ_dec (dec_trm a T)) ->
     ty_trm G (trm_sel (var_termvar_f x) a) T
 | ty_let : forall (L:vars) (G:ctx) (t1 t2:trm) (T2 T1:typ),
     ty_trm G t1 T1 ->
      ( forall x , x \notin  L  -> ty_trm  ( x ~ T1  ++  G )   ( open_trm_wrt_varref t2 (var_termvar_f x) )  T2 )  ->
     ty_trm G (trm_let t1 t2) T2
 | ty_rec_intro : forall (L:vars) (G:ctx) (x:termvar) (T:typ),
      ( forall z , z \notin  L  -> ty_trm G (trm_var (var_termvar_f x))  ( open_typ_wrt_varref T (var_termvar_f z) )  )  ->
     ty_trm G (trm_var (var_termvar_f x)) (typ_bnd T)
 | ty_rec_elim : forall (G:ctx) (x:termvar) (T:typ),
     ty_trm G (trm_var (var_termvar_f x)) (typ_bnd T) ->
     ty_trm G (trm_var (var_termvar_f x))  (open_typ_wrt_varref  T   (var_termvar_f x) )
 | ty_and_intro : forall (G:ctx) (x:termvar) (T1 T2:typ),
     ty_trm G (trm_var (var_termvar_f x)) T1 ->
     ty_trm G (trm_var (var_termvar_f x)) T2 ->
     ty_trm G (trm_var (var_termvar_f x)) (typ_and T1 T2)
 | ty_sub : forall (G:ctx) (t:trm) (T2 T1:typ),
     ty_trm G t T1 ->
     subtyp G T1 T2 ->
     ty_trm G t T2
with ty_def : ctx -> def -> typ -> Prop :=    (* defn ty_def *)
 | ty_def_trm : forall (G:ctx) (a:trmlabel) (t:trm) (T:typ),
     ty_trm G t T ->
     ty_def G (def_trm a t) (typ_dec (dec_trm a T))
 | ty_def_typ : forall (G:ctx) (A:typlabel) (T:typ),
     lc_typ T ->
     ty_def G (def_typ A T) (typ_dec (dec_typ A T T))
with ty_defs : ctx -> defs -> typ -> Prop :=    (* defn ty_defs *)
 | ty_defs_one : forall (G:ctx) (d:def) (T:typ),
     ty_def G d T ->
     ty_defs G (defs_cons d defs_nil) T
 | ty_defs_cons : forall (G:ctx) (d:def) (defs5:defs) (T1 T2:typ),
     ty_def G d T1 ->
     ty_defs G defs5 T2 ->
     ty_defs G (defs_cons d defs5) (typ_and T1 T2)
with subtyp : ctx -> typ -> typ -> Prop :=    (* defn subtyp *)
 | subtyp_top : forall (G:ctx) (T:typ),
     lc_typ T ->
     subtyp G T typ_top
 | subtyp_bot : forall (G:ctx) (T:typ),
     lc_typ T ->
     subtyp G typ_bot T
 | subtyp_refl : forall (G:ctx) (T:typ),
     lc_typ T ->
     subtyp G T T
 | subtyp_trans : forall (G:ctx) (T1 T3 T2:typ),
     subtyp G T1 T2 ->
     subtyp G T2 T3 ->
     subtyp G T1 T3
 | subtyp_and11 : forall (G:ctx) (T1 T2:typ),
     lc_typ T2 ->
     lc_typ T1 ->
     subtyp G (typ_and T1 T2) T1
 | subtyp_and12 : forall (G:ctx) (T1 T2:typ),
     lc_typ T1 ->
     lc_typ T2 ->
     subtyp G (typ_and T1 T2) T2
 | subtyp_and2 : forall (G:ctx) (T1 T2 T3:typ),
     subtyp G T1 T2 ->
     subtyp G T1 T3 ->
     subtyp G T1 (typ_and T2 T3)
 | subtyp_fld : forall (G:ctx) (a:trmlabel) (T1 T2:typ),
     subtyp G T1 T2 ->
     subtyp G (typ_dec (dec_trm a T1)) (typ_dec (dec_trm a T2))
 | subtyp_typ : forall (G:ctx) (A:typlabel) (T2 T3 T1 T4:typ),
     subtyp G T1 T2 ->
     subtyp G T3 T4 ->
     subtyp G (typ_dec (dec_typ A T2 T3)) (typ_dec (dec_typ A T1 T4))
 | subtyp_sel1 : forall (G:ctx) (x:termvar) (A:typlabel) (T2 T1:typ),
     ty_trm G (trm_var (var_termvar_f x)) (typ_dec (dec_typ A T1 T2)) ->
     subtyp G (typ_sel (var_termvar_f x) A) T2
 | subtyp_sel2 : forall (G:ctx) (T1:typ) (x:termvar) (A:typlabel) (T2:typ),
     ty_trm G (trm_var (var_termvar_f x)) (typ_dec (dec_typ A T1 T2)) ->
     subtyp G T1 (typ_sel (var_termvar_f x) A)
 | subtyp_all : forall (L:vars) (G:ctx) (T1 T2 T3 T4:typ),
     subtyp G T3 T1 ->
      ( forall x , x \notin  L  -> subtyp  ( x ~ T1  ++  G )   ( open_typ_wrt_varref T2 (var_termvar_f x) )   ( open_typ_wrt_varref T4 (var_termvar_f x) )  )  ->
     subtyp G (typ_all T1 T2) (typ_all T3 T4).

(* defns Inert *)
Inductive record_type : typ -> Prop :=    (* defn record_type *)
 | rt_one_trm : forall (a:trmlabel) (T:typ),
     lc_typ T ->
     record_type (typ_dec (dec_trm a T))
 | rt_one_typ : forall (A:typlabel) (T:typ),
     lc_typ T ->
     record_type (typ_dec (dec_typ A T T))
 | rt_and_trm : forall (T1:typ) (a:trmlabel) (T2:typ),
     lc_typ T2 ->
     record_type T1 ->
      ( a  \notin type_labels  T1 )  ->
     record_type (typ_and T1 (typ_dec (dec_trm a T2)))
 | rt_and_typ : forall (T1:typ) (A:typlabel) (T2:typ),
     lc_typ T2 ->
     record_type T1 ->
      ( A  \notin type_labels  T1 )  ->
     record_type (typ_and T1 (typ_dec (dec_typ A T2 T2)))
with inert_typ : typ -> Prop :=    (* defn inert_typ *)
 | inert_typ_all : forall (T1 T2:typ),
     lc_typ T1 ->
     lc_typ (typ_all T1 T2) ->
     inert_typ (typ_all T1 T2)
 | inert_typ_bnd : forall (L:vars) (T:typ),
      ( forall x , x \notin  L  -> record_type  ( open_typ_wrt_varref T (var_termvar_f x) )  )  ->
     inert_typ (typ_bnd T)
with inert_ctx : ctx -> Prop :=    (* defn inert_ctx *)
 | inert_empty :
     inert_ctx  nil
 | inert_all : forall (G:ctx) (x:termvar) (T:typ),
     inert_ctx G ->
     inert_typ T ->
      ( x  \notin dom  G )  ->
     inert_ctx  ( x ~ T  ++  G ) .

(* defns PreciseTyping *)
Inductive ty_val_p : ctx -> val -> typ -> Prop :=    (* defn ty_val_p *)
 | ty_all_intro_p : forall (L:vars) (G:ctx) (T1:typ) (t:trm) (T2:typ),
      ( forall x , x \notin  L  -> ty_trm  ( x ~ T1  ++  G )   ( open_trm_wrt_varref t (var_termvar_f x) )   ( open_typ_wrt_varref T2 (var_termvar_f x) )  )  ->
     ty_val_p G (val_lambda T1 t) (typ_all T1 T2)
 | ty_new_intro_p : forall (L:vars) (G:ctx) (T:typ) (defs5:defs),
      ( forall x , x \notin  L  -> ty_defs  ( x ~  ( open_typ_wrt_varref T (var_termvar_f x) )   ++  G )   ( open_defs_wrt_varref defs5 (var_termvar_f x) )   ( open_typ_wrt_varref T (var_termvar_f x) )  )  ->
      ( forall x , x \notin  L  -> ty_val_p G (val_new  ( open_typ_wrt_varref T (var_termvar_f x) )  defs5) (typ_bnd T) )
with precise_flow : ctx -> termvar -> typ -> typ -> Prop :=    (* defn precise_flow *)
 | pf_bind : forall (G:ctx) (x:termvar) (T:typ),
      (binds ( x ) ( T ) ( G ))  ->
     precise_flow G x T T
 | pf_open : forall (G:ctx) (x:termvar) (T1 T2:typ),
     precise_flow G x T1 (typ_bnd T2) ->
     precise_flow G x T1  (open_typ_wrt_varref  T2   (var_termvar_f x) )
 | pf_and1 : forall (G:ctx) (x:termvar) (T1 T2 T3:typ),
     precise_flow G x T1 (typ_and T2 T3) ->
     precise_flow G x T1 T2
 | pf_and2 : forall (G:ctx) (x:termvar) (T1 T3 T2:typ),
     precise_flow G x T1 (typ_and T2 T3) ->
     precise_flow G x T1 T3.

(* defns TightTyping *)
Inductive ty_trm_t : ctx -> trm -> typ -> Prop :=    (* defn ty_trm_t *)
 | ty_var_t : forall (G:ctx) (x:termvar) (T:typ),
      (binds ( x ) ( T ) ( G ))  ->
     ty_trm_t G (trm_var (var_termvar_f x)) T
 | ty_all_intro_t : forall (L:vars) (G:ctx) (T1:typ) (t:trm) (T2:typ),
      ( forall x , x \notin  L  -> ty_trm  ( x ~ T1  ++  G )   ( open_trm_wrt_varref t (var_termvar_f x) )   ( open_typ_wrt_varref T2 (var_termvar_f x) )  )  ->
     ty_trm_t G (trm_val (val_lambda T1 t)) (typ_all T1 T2)
 | ty_all_elim_t : forall (G:ctx) (x y:termvar) (T2 T1:typ),
     ty_trm_t G (trm_var (var_termvar_f x)) (typ_all T1 T2) ->
     ty_trm_t G (trm_var (var_termvar_f y)) T1 ->
     ty_trm_t G (trm_app (var_termvar_f x) (var_termvar_f y))  (open_typ_wrt_varref  T2   (var_termvar_f y) )
 | ty_new_intro_t : forall (L:vars) (G:ctx) (T:typ) (defs5:defs),
      ( forall x , x \notin  L  -> ty_defs  ( x ~  ( open_typ_wrt_varref T (var_termvar_f x) )   ++  G )   ( open_defs_wrt_varref defs5 (var_termvar_f x) )   ( open_typ_wrt_varref T (var_termvar_f x) )  )  ->
      ( forall x , x \notin  L  -> ty_trm_t G (trm_val (val_new  ( open_typ_wrt_varref T (var_termvar_f x) )  defs5)) (typ_bnd T) )
 | ty_new_elim_t : forall (G:ctx) (x:termvar) (a:trmlabel) (T:typ),
     ty_trm_t G (trm_var (var_termvar_f x)) (typ_dec (dec_trm a T)) ->
     ty_trm_t G (trm_sel (var_termvar_f x) a) T
 | ty_let_t : forall (L:vars) (G:ctx) (t1 t2:trm) (T2 T1 T:typ),
     ty_trm_t G t1 T1 ->
      ( forall x , x \notin  L  -> ty_trm  ( x ~ T  ++  G )   ( open_trm_wrt_varref t2 (var_termvar_f x) )  T2 )  ->
     ty_trm_t G (trm_let t1 t2) T2
 | ty_rec_intro_t : forall (L:vars) (G:ctx) (x:termvar) (T:typ),
      ( forall z , z \notin  L  -> ty_trm_t G (trm_var (var_termvar_f x))  ( open_typ_wrt_varref T (var_termvar_f z) )  )  ->
     ty_trm_t G (trm_var (var_termvar_f x)) (typ_bnd T)
 | ty_rec_elim_t : forall (G:ctx) (x:termvar) (T:typ),
     ty_trm_t G (trm_var (var_termvar_f x)) (typ_bnd T) ->
     ty_trm_t G (trm_var (var_termvar_f x))  (open_typ_wrt_varref  T   (var_termvar_f x) )
 | ty_and_intro_t : forall (G:ctx) (x:termvar) (T1 T2:typ),
     ty_trm_t G (trm_var (var_termvar_f x)) T1 ->
     ty_trm_t G (trm_var (var_termvar_f x)) T2 ->
     ty_trm_t G (trm_var (var_termvar_f x)) (typ_and T1 T2)
 | ty_sub_t : forall (G:ctx) (t:trm) (T2 T1:typ),
     ty_trm_t G t T1 ->
     subtyp_t G T1 T2 ->
     ty_trm_t G t T2
with subtyp_t : ctx -> typ -> typ -> Prop :=    (* defn subtyp_t *)
 | subtyp_top_t : forall (G:ctx) (T:typ),
     lc_typ T ->
     subtyp_t G T typ_top
 | subtyp_bot_t : forall (G:ctx) (T:typ),
     lc_typ T ->
     subtyp_t G typ_bot T
 | subtyp_refl_t : forall (G:ctx) (T:typ),
     lc_typ T ->
     subtyp_t G T T
 | subtyp_trans_t : forall (G:ctx) (T1 T3 T2:typ),
     subtyp_t G T1 T2 ->
     subtyp_t G T2 T3 ->
     subtyp_t G T1 T3
 | subtyp_and11_t : forall (G:ctx) (T1 T2:typ),
     lc_typ T2 ->
     lc_typ T1 ->
     subtyp_t G (typ_and T1 T2) T1
 | subtyp_and12_t : forall (G:ctx) (T1 T2:typ),
     lc_typ T1 ->
     lc_typ T2 ->
     subtyp_t G (typ_and T1 T2) T2
 | subtyp_and2_t : forall (G:ctx) (T1 T2 T3:typ),
     subtyp_t G T1 T2 ->
     subtyp_t G T1 T3 ->
     subtyp_t G T1 (typ_and T2 T3)
 | subtyp_fld_t : forall (G:ctx) (a:trmlabel) (T1 T2:typ),
     subtyp_t G T1 T2 ->
     subtyp_t G (typ_dec (dec_trm a T1)) (typ_dec (dec_trm a T2))
 | subtyp_typ_t : forall (G:ctx) (A:typlabel) (T2 T3 T1 T4:typ),
     subtyp_t G T1 T2 ->
     subtyp_t G T3 T4 ->
     subtyp_t G (typ_dec (dec_typ A T2 T3)) (typ_dec (dec_typ A T1 T4))
 | subtyp_sel1_t : forall (G:ctx) (x:termvar) (A:typlabel) (T2 T1:typ),
     precise_flow G x T1 (typ_dec (dec_typ A T2 T2)) ->
     subtyp_t G (typ_sel (var_termvar_f x) A) T2
 | subtyp_sel2_t : forall (G:ctx) (T2:typ) (x:termvar) (A:typlabel) (T1:typ),
     precise_flow G x T1 (typ_dec (dec_typ A T2 T2)) ->
     subtyp_t G T2 (typ_sel (var_termvar_f x) A)
 | subtyp_all_t : forall (L:vars) (G:ctx) (T1 T2 T3 T4:typ),
     subtyp_t G T3 T1 ->
      ( forall x , x \notin  L  -> subtyp  ( x ~ T1  ++  G )   ( open_typ_wrt_varref T2 (var_termvar_f x) )   ( open_typ_wrt_varref T4 (var_termvar_f x) )  )  ->
     subtyp_t G (typ_all T1 T2) (typ_all T3 T4).

(* defns InvertibleTyping *)
Inductive ty_var_inv : ctx -> termvar -> typ -> Prop :=    (* defn ty_var_inv *)
 | ty_precise_inv : forall (G:ctx) (x:termvar) (T2 T1:typ),
     precise_flow G x T1 T2 ->
     ty_var_inv G x T2
 | ty_dec_trm_inv : forall (G:ctx) (x:termvar) (a:trmlabel) (T2 T1:typ),
     ty_var_inv G x (typ_dec (dec_trm a T1)) ->
     subtyp_t G T1 T2 ->
     ty_var_inv G x (typ_dec (dec_trm a T2))
 | ty_dec_typ_inv : forall (G:ctx) (x:termvar) (A:typlabel) (T1 T4 T2 T3:typ),
     ty_var_inv G x (typ_dec (dec_typ A T2 T3)) ->
     subtyp_t G T1 T2 ->
     subtyp_t G T3 T4 ->
     ty_var_inv G x (typ_dec (dec_typ A T1 T4))
 | ty_bnd_inv : forall (G:ctx) (x:termvar) (T:typ),
     ty_var_inv G x  (open_typ_wrt_varref  T   (var_termvar_f x) )  ->
     ty_var_inv G x (typ_bnd T)
 | ty_all_inv : forall (L:vars) (G:ctx) (x:termvar) (T1 T4 T2 T3:typ),
     ty_var_inv G x (typ_all T2 T3) ->
     subtyp_t G T1 T2 ->
      ( forall z , z \notin  L  -> subtyp  ( z ~ T1  ++  G )   ( open_typ_wrt_varref T3 (var_termvar_f z) )   ( open_typ_wrt_varref T4 (var_termvar_f z) )  )  ->
     ty_var_inv G x (typ_all T1 T4)
 | ty_and_inv : forall (G:ctx) (x:termvar) (T1 T2:typ),
     ty_var_inv G x T1 ->
     ty_var_inv G x T2 ->
     ty_var_inv G x (typ_and T1 T2)
 | ty_sel_inv : forall (G:ctx) (x y:termvar) (A:typlabel) (T1 T2:typ),
     ty_var_inv G x T1 ->
     precise_flow G y T2 (typ_dec (dec_typ A T1 T1)) ->
     ty_var_inv G x (typ_sel (var_termvar_f y) A)
 | ty_top_inv : forall (G:ctx) (x:termvar) (T:typ),
     ty_var_inv G x T ->
     ty_var_inv G x typ_top
with ty_val_inv : ctx -> val -> typ -> Prop :=    (* defn ty_val_inv *)
 | ty_precise_inv_v : forall (G:ctx) (val5:val) (T:typ),
     ty_val_p G val5 T ->
     ty_val_inv G val5 T
 | ty_all_inv_v : forall (L:vars) (G:ctx) (val5:val) (T1 T4 T2 T3:typ),
     ty_val_inv G val5 (typ_all T2 T3) ->
     subtyp_t G T1 T2 ->
      ( forall z , z \notin  L  -> subtyp  ( z ~ T1  ++  G )   ( open_typ_wrt_varref T3 (var_termvar_f z) )   ( open_typ_wrt_varref T4 (var_termvar_f z) )  )  ->
     ty_val_inv G val5 (typ_all T1 T4)
 | ty_and_inv_v : forall (G:ctx) (val5:val) (T1 T2:typ),
     ty_val_inv G val5 T1 ->
     ty_val_inv G val5 T2 ->
     ty_val_inv G val5 (typ_and T1 T2)
 | ty_sel_inv_v : forall (G:ctx) (val5:val) (y:termvar) (A:typlabel) (T1 T2:typ),
     ty_val_inv G val5 T1 ->
     precise_flow G y T2 (typ_dec (dec_typ A T1 T1)) ->
     ty_val_inv G val5 (typ_sel (var_termvar_f y) A)
 | ty_top_inv_v : forall (G:ctx) (val5:val) (T:typ),
     ty_val_inv G val5 T ->
     ty_val_inv G val5 typ_top.

(* defns OperationalSemantics *)
Inductive red : stack -> trm -> stack -> trm -> Prop :=    (* defn red *)
 | red_sel : forall (s:stack) (x:termvar) (a:trmlabel) (t:trm) (T:typ) (defs5:defs),
      (binds ( x ) ( (trm_val (val_new T defs5)) ) ( s ))  ->
      (defs_has   (open_defs_wrt_varref  defs5   (var_termvar_f x) )    (def_trm a t) )  ->
     red s (trm_sel (var_termvar_f x) a) s t
 | red_app : forall (s:stack) (x y:termvar) (t:trm) (T1:typ),
      (binds ( x ) ( (trm_val (val_lambda T1 t)) ) ( s ))  ->
     red s (trm_app (var_termvar_f x) (var_termvar_f y)) s  (open_trm_wrt_varref  t   (var_termvar_f y) )
 | red_let_val : forall (L:vars) (s:stack) (val5:val) (t:trm),
     lc_trm (trm_let (trm_val val5) t) ->
     lc_val val5 ->
      ( forall x , x \notin  L  -> red s (trm_let (trm_val val5) t)  ( x ~ (trm_val val5)  ++  s )   ( open_trm_wrt_varref t (var_termvar_f x) )  )
 | red_let_var : forall (s:stack) (y:termvar) (t:trm),
     lc_trm (trm_let (trm_var (var_termvar_f y)) t) ->
     red s (trm_let (trm_var (var_termvar_f y)) t) s  (open_trm_wrt_varref  t   (var_termvar_f y) )
 | red_let_tgt : forall (s1:stack) (t1 t3:trm) (s2:stack) (t2:trm),
     lc_trm (trm_let t1 t3) ->
     red s1 t1 s2 t2 ->
     red s1 (trm_let t1 t3) s2 (trm_let t2 t3).

(** infrastructure *)
Hint Constructors ty_trm ty_def ty_defs subtyp record_type inert_typ inert_ctx ty_val_p precise_flow ty_trm_t subtyp_t ty_var_inv ty_val_inv red lc_varref lc_dec lc_typ lc_def lc_defs lc_val lc_trm.


Require Import Coq.ZArith.ZArith.
Require Import Coq.Lists.List.
Require Import compcert.common.AST. (* For ident. *)
Require Import liblayers.compcertx.ErrorMonad.
Require Import liblayers.lib.OptionMonad.
Require Import liblayers.lib.Decision.
Require Import liblayers.logic.PseudoJoin.
Require Import liblayers.logic.OptionOrders.
Require Import liblayers.logic.PTrees.
Require Import liblayers.logic.Modules.
Require Import liblayers.logic.PTreeModules.
Require Import liblayers.logic.GlobalVars.

(** Total maps between two PTreeModules. *)

Section WITHMAP.

  Context
    {F_from F_to V_from V_to}
    {gvar_from_ops: GlobalVarsOps V_from}
    {gvar_from_to: GlobalVarsOps V_to}
    (ff: ident -> F_from -> F_to)
    (fv: ident -> V_from -> V_to)
  .

  Definition map (M: ptree_module F_from V_from): ptree_module F_to V_to :=
    (PTree.map (fun i => fmap (ff i)) (fst M), PTree.map (fun i => fmap (fv i)) (snd M)).

  Existing Instance ptree_module_ops.

  Lemma get_module_function_map i (M: ptree_module F_from V_from):
    get_module_function i (map M) = fmap (option_map (ff i)) (get_module_function i M).
  Proof.
    simpl.
    unfold get_module_function.
    Local Transparent ptree_module_ops.
    unfold ptree_module_ops.
    unfold ptree_module_function.
    simpl.
    rewrite PTree.gmap.
    destruct (PTree.get i (fst M)); simpl; auto.
    destruct r; simpl; auto.
  Qed.

  Lemma get_module_variable_map i (M: ptree_module F_from V_from):
    get_module_variable i (map M) = fmap (option_map (fv i)) (get_module_variable i M).
  Proof.
    simpl.
    unfold get_module_variable.
    Local Transparent ptree_module_ops.
    unfold ptree_module_ops.
    unfold ptree_module_variable.
    simpl.
    rewrite PTree.gmap.
    destruct (PTree.get i (snd M)); simpl; auto.
    destruct r; simpl; auto.
  Qed.

End WITHMAP.

Section WITHMAPERROR.

  Context
    {F_from F_to V_from V_to}
    {gvar_from_ops: GlobalVarsOps V_from}
    {gvar_from_to: GlobalVarsOps V_to}
    (ff: ident -> F_from -> res F_to)
    (fv: ident -> V_from -> res V_to)
  .

  Definition map_error (M: ptree_module F_from V_from): ptree_module F_to V_to :=
    (PTree.map (fun i x => Errors.bind x (ff i)) (fst M), PTree.map (fun i x => Errors.bind x (fv i)) (snd M)).

  Existing Instance ptree_module_ops.

  Lemma get_module_function_map_error i (M: ptree_module F_from V_from):
    get_module_function i (map_error M) = option_res_flip (option_map (fun x => Errors.bind x (ff i)) (res_option_flip (get_module_function i M))).
  Proof.
    simpl.
    unfold get_module_function.
    Local Transparent ptree_module_ops.
    unfold ptree_module_ops.
    unfold ptree_module_function.
    simpl.
    rewrite PTree.gmap.
    rewrite option_res_flip_inv.
    reflexivity.
  Qed.

  Lemma get_module_variable_map_error i (M: ptree_module F_from V_from):
    get_module_variable i (map_error M) = option_res_flip (option_map (fun x => Errors.bind x (fv i)) (res_option_flip (get_module_variable i M))).
  Proof.
    simpl.
    unfold get_module_variable.
    Local Transparent ptree_module_ops.
    unfold ptree_module_ops.
    unfold ptree_module_variable.
    simpl.
    rewrite PTree.gmap.
    rewrite option_res_flip_inv.
    reflexivity.
  Qed.

End WITHMAPERROR.


From mathcomp Require Import
  ssreflect ssrfun ssrbool eqtype ssrnat seq choice fintype div ssrint ssralg
  intdiv.
From extructures Require Import ord fmap.
From CoqUtils Require Import word.

Require Import lib.utils common.types.

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

Section Relocation.

Context {mt : machine_types}
        {ops : machine_ops mt}.

(* The type of relocatable memory segments.  The first nat specifies
   the segment's size.  The argument type specifies what kind of
   relocation information is needed (e.g., nothing for constant
   segments; just one word for relocatable code; a pair of words for
   relocatable code that also needs access to a shared data area).

   TODO: One issue is that we need the resulting list to always be of
   the specified size, but the type does not demand this at the
   moment.  One way to deal with this is to add a proof component that
   certifies that the resulting list always has the specified length.
   Is there a better way?  (This seems not too bad: our structured
   code combinators can build these certificates pretty easily.) *)

Definition relocatable_segment :=
  fun Args => fun Cell => (nat * (mword mt -> Args -> seq Cell))%type.

Definition empty_relocatable_segment (Args Cell : Type) : relocatable_segment Args Cell :=
  (0, fun (base : mword mt) (rest : Args) => [::]).

(* Concatenates list of relocatable segments into one, returning a
   list of offsets (relative to the base address). *)
Definition concat_and_measure_relocatable_segments
             (Args Cell : Type)
             (segs : seq (relocatable_segment Args Cell))
           : relocatable_segment Args Cell * seq nat :=
  foldl
    (fun (p : relocatable_segment Args Cell * seq nat)
         (seg : relocatable_segment Args Cell) =>
       let: (acc,addrs) := p in
       let (l1,gen1) := acc in
       let (l2,gen2) := seg in
       let gen := fun (base : mword mt) (rest : Args) =>
                       gen1 base rest
                    ++ gen2 (addw base (as_word l1)) rest in
       let newseg := (l1+l2, gen) in
       (newseg, addrs ++ [:: l1]))
    (empty_relocatable_segment _ _, [::])
    segs.

Definition concat_relocatable_segments
             (Args Cell : Type)
             (segs : seq (relocatable_segment Args Cell))
           : relocatable_segment Args Cell :=
  fst (concat_and_measure_relocatable_segments segs).

Definition map_relocatable_segment
             (Args Cell Cell' : Type)
             (f : Cell -> Cell')
             (seg : relocatable_segment Args Cell)
           : relocatable_segment Args Cell' :=
  let (l,gen) := seg in
  let gen' := fun (base : mword mt) (rest : Args) => map f (gen base rest) in
  (l, gen').

Definition relocate_ignore_args
             (Args Cell : Type)
             (seg : relocatable_segment unit Cell)
           : relocatable_segment Args Cell :=
  let (l,gen) := seg in
  let gen' := fun (base : mword mt) (rest : Args) => gen base tt in
  (l, gen').

End Relocation.

Ltac current_instr_opcode :=
  match goal with
  | H : decode_instr _ = Some ?instr |- _ =>
    let op := (eval compute in (opcode_of instr)) in
    op
  end.


From Cat Require Import Imports Category Preorder Monoid Poset Isomorphism Terminal Dual Initial Product CoProduct Exponential CCC.

Local Open Scope list_scope.

Inductive IPL: Type :=
 | pi   : IPL
 | truth: IPL
 | conju: IPL -> IPL -> IPL
 | impli: IPL -> IPL -> IPL.

Definition ctx := list (IPL)%type.

Definition extend (c: ctx) (x: IPL) := x :: c.

Fixpoint recI (P: PreOrder) (h1: top P) (h2: hasPOBM P) (h3: hasPOHI P h2) (l: list IPL) (M: IPL -> (@obj (@uc (PreOrderDetCatisCCC P h1 h2 h3)))):
  (@obj (@uc (PreOrderDetCatisCCC P h1 h2 h3))) :=
  match l with
    | nil     => @tobj (@uc (PreOrderDetCatisCCC P h1 h2 h3))
                       (@hasT (@uc (PreOrderDetCatisCCC P h1 h2 h3))
                       (@uobs (PreOrderDetCatisCCC P h1 h2 h3)))
    | x :: xs => @pobj (@uc (PreOrderDetCatisCCC P h1 h2 h3))
                       (@hasP (@uc (PreOrderDetCatisCCC P h1 h2 h3)) (@uobs (PreOrderDetCatisCCC P h1 h2 h3)))
                       (M x) (recI P h1 h2 h3 xs M)
   end.

Class interp (P: PreOrder) (h1: top P) (h2: hasPOBM P) (h3: hasPOHI P h2): Type :=
{
   M : IPL -> (@obj (@uc (PreOrderDetCatisCCC P h1 h2 h3)));
   i1: { p: (@obj (@uc (PreOrderDetCatisCCC P h1 h2 h3))) | M pi = p };
   i2: M truth = @tobj (@uc (PreOrderDetCatisCCC P h1 h2 h3))
                       (@hasT (@uc (PreOrderDetCatisCCC P h1 h2 h3))
                       (@uobs (PreOrderDetCatisCCC P h1 h2 h3)));
   i3: forall p q, M (conju p q) = @pobj (@uc (PreOrderDetCatisCCC P h1 h2 h3))
                                         (@hasP (@uc (PreOrderDetCatisCCC P h1 h2 h3)) (@uobs (PreOrderDetCatisCCC P h1 h2 h3))) (M p) (M q);
   i4: forall p q, M (impli p q) = @eobj (@uc (PreOrderDetCatisCCC P h1 h2 h3))
                                         (@hasP (@uc (PreOrderDetCatisCCC P h1 h2 h3)) (@uobs (PreOrderDetCatisCCC P h1 h2 h3)))
                                         (@hasE (@uc (PreOrderDetCatisCCC P h1 h2 h3)) (@uobs (PreOrderDetCatisCCC P h1 h2 h3))) (M p) (M q);
   ML: ctx -> (@obj (@uc (PreOrderDetCatisCCC P h1 h2 h3)));
   i5: forall (l: ctx), ML l = recI P h1 h2 h3 l M
}.

Lemma listc: forall (c: ctx) (x: IPL) (P: PreOrder) (h1: top P) (h2: hasPOBM P) (h3: hasPOHI P h2) (i: interp P h1 h2 h3),
 ((@ML P h1 h2 h3 i) (x :: c)) = @pobj (@uc (PreOrderDetCatisCCC P h1 h2 h3))
                                       (@hasP (@uc (PreOrderDetCatisCCC P h1 h2 h3)) (@uobs (PreOrderDetCatisCCC P h1 h2 h3)))
                                       ((@M P h1 h2 h3 i) x) ((@ML P h1 h2 h3 i) c) .
Proof. intro c.
       induction c; intros.
       - destruct i.
         simpl in *.
         destruct h2 as (h2).
         destruct h1.
         compute. rewrite !i10.
         simpl. compute. easy.
       - rewrite IHc.
         destruct i.
         destruct h2 as (h2).
         destruct h3 as (h3).
         destruct h1.
         simpl in *.
         rewrite !i10. easy.
Qed.

(** one can decude the IPL formula x in the context [x]; namely [x] |- x *)
Lemma soundR: forall (x: IPL) (P: PreOrder) (h1: top P) (h2: hasPOBM P) (h3: hasPOHI P h2) (i: interp P h1 h2 h3),
  @pohrel P ((@ML P h1 h2 h3 i) (x :: nil))  ((@M P h1 h2 h3 i) x) = true.
Proof. intros.
       simpl.
       destruct i.
       simpl in *.
       specialize (i10 (x :: nil)).
       rewrite i10.
       destruct h2 as (h2).
       destruct h1.
       simpl in *.
       destruct (h2 (M0 x) ptop).
       simpl.
       clear i10.
       exact pobmpi1.
Qed.

Lemma soundRc: forall (c: ctx) (x: IPL) (P: PreOrder) (h1: top P) (h2: hasPOBM P) (h3: hasPOHI P h2) (i: interp P h1 h2 h3),
  @pohrel P ((@ML P h1 h2 h3 i) (x :: c))  ((@M P h1 h2 h3 i) x) = true.
Proof. intro c.
       induction c; intros.
       - apply soundR.
       - simpl in *.
         rewrite listc.
         simpl.
         specialize (IHc x P h1 h2 h3 i).
         destruct i.
         simpl in *.
         destruct h2 as (h2).
         destruct h1.
         destruct P.
         simpl in *.
         compute.
         destruct (h2 (M0 x) (ML0 (a :: c))).
         exact pobmpi1.
Qed.

Lemma soundR2: forall (x y: IPL) (P: PreOrder) (h1: top P) (h2: hasPOBM P) (h3: hasPOHI P h2) (i: interp P h1 h2 h3),
  @pohrel P ((@ML P h1 h2 h3 i) (x :: y :: nil)) ((@M P h1 h2 h3 i) x) = true.
Proof. intros.
       apply soundRc.
Qed.

Inductive IPLE: ctx -> IPL -> Prop :=
  | ax1: forall (c: ctx) (p: IPL), IPLE (p :: c) p
  | ax2: forall (c: ctx) (p q: IPL), IPLE c p -> IPLE (q :: c) p
  | ax3: forall (c: ctx) (p q: IPL), IPLE c p -> IPLE (p :: c) q -> IPLE c q
  | ax4: forall (c: ctx), IPLE c truth
  | ax5: forall (c: ctx) (p q: IPL), IPLE c p -> IPLE c q -> IPLE c (conju p q)
  | ax6: forall (c: ctx) (p q: IPL), IPLE (p :: c) q -> IPLE c (impli p q)
  | ax7: forall (c: ctx) (p q: IPL), IPLE c (conju p q) -> IPLE c p
  | ax8: forall (c: ctx) (p q: IPL), IPLE c (conju p q) -> IPLE c q
  | ax9: forall (c: ctx) (p q: IPL), IPLE c (impli p q) -> IPLE c p -> IPLE c q.

Example IPLExample_woCut: forall (phi psi theta: IPL),
  IPLE ((impli phi psi) :: (impli psi theta) :: nil)
       (impli phi theta).
Proof. intros.
       apply ax6.
       apply ax9 with (p := psi).
       - apply ax2.
         apply ax2.
         apply ax1.
       - apply ax9 with (p := phi).
         + apply ax2.
           apply ax1.
         + apply ax1.
Qed.

Lemma PO_POIC_l: forall (P: PreOrder) (x y: @pos P) (C := PreOrderDetCat P),
  @pohrel P x y = true -> @arrow C y x.
Proof. intros (P, R, r, t) x y C H.
       unfold PreOrderDetCat in C.
       simpl in *.
       destruct C.
       unfold PreOrderICMap.
       simpl.
       rewrite H.
       exact tt.
Qed.

Lemma PO_POIC_r: forall (P: PreOrder) (x y: @pos P) (C := PreOrderDetCat P),
   @arrow C y x -> @pohrel P x y = true.
Proof. intros (P, R, r, t) x y C H.
       unfold PreOrderDetCat in C.
       simpl in *.
       destruct C.
       unfold PreOrderICMap in H.
       simpl in H.
       case_eq (R x y); intro HH.
       - easy.
       - rewrite HH in H. easy.
Qed.

Lemma soundnessIPL_CCP: forall (x: IPL) (c: ctx) (P: PreOrder) (h1: top P) (h2: hasPOBM P) (h3: hasPOHI P h2) (i: interp P h1 h2 h3)
  (C := PreOrderDetCat P),
  IPLE c x ->
  @arrow C ((@M P h1 h2 h3 i) x) ((@ML P h1 h2 h3 i) c).
Proof. intros x c P h1 h2 h3 i C H.
       apply PO_POIC_l.
       revert P h1 h2 h3 C i.
       induction H; intros.
       - apply soundRc.
       - simpl.
         rewrite listc.
         specialize (IHIPLE P h1 h2 h3 i).
         simpl in *.
         destruct i.
         simpl in *.
         specialize (i10 (q :: c)).
         destruct h2 as (h2).
         destruct h1.
         destruct P.
         compute.
         destruct (h2 (M0 q) (ML0 c)).
         simpl in *.
         assert (pohrel pobm (ML0 c) = true /\ pohrel (ML0 c) (M0 p) = true) by easy.
         clear h2 h3 i8 i9 i10 C.
         specialize (potrans _ _ _ H0). easy.
       - simpl in *.
         specialize (IHIPLE1 P h1 h2 h3 i).
         specialize (IHIPLE2 P h1 h2 h3 i).
         rewrite listc in IHIPLE2.
         simpl in IHIPLE2.
         destruct i.
         simpl in *.
         destruct h2 as (h2).
         destruct h1.
         destruct P.
         simpl in *.
         compute in IHIPLE2.
         destruct (h2 (M0 p) (ML0 c)).
         simpl in *.
         specialize (pobmuni (ML0 c)).
         assert (pohrel (ML0 c) (M0 p) = true /\ pohrel (ML0 c) (ML0 c) = true) by easy.
         apply pobmuni in H1.
         assert (pohrel (ML0 c) pobm = true /\ pohrel pobm (M0 q) = true) by easy.
         clear h2 h3 i8 i9 i10 C.
         specialize (potrans _ _ _ H2). easy.
       - simpl in *.
         destruct i.
         simpl in *.
         destruct h2 as (h2).
         destruct h1.
         simpl in *.
         rewrite i7, potob.
         easy.
       - specialize (IHIPLE1 P h1 h2 h3 i).
         specialize (IHIPLE2 P h1 h2 h3 i).
         destruct i as (M, i1, i2, i3, i4, ML, recI).
         simpl in *.
         destruct h2 as (h2).
         destruct h1.
         simpl in *.
         specialize (i3 p q).
         rewrite i3.
         destruct (h2 (M p) (M q)).
         simpl in *.
         specialize (pobmuni (ML c)).
         rewrite pobmuni.
         easy.
       - simpl in *.
         specialize (IHIPLE P h1 h2 h3 i).
         rewrite listc in IHIPLE.
         destruct i as (M, i1, i2, i3, i4, ML, recI).
         destruct h2 as (h2).
         destruct h3 as (h3).
         destruct h1.
         simpl in *.
         specialize (i4 p q).
         destruct (h3 (M p) (M q)).
         simpl in *.
         specialize (hiob (ML c)).
         destruct (h2 (ML c) (M p)).
         destruct hiob.
         simpl in *.
         destruct (h2 (M p) (ML c)).
         destruct (h2 hi (M p)).
         simpl in *.
         rewrite i4.

         apply H1.
         specialize (pobmuni1 pobm0).
         assert (pohrel pobm (M p) = true /\ pohrel pobm (ML c) = true) by easy.
         apply pobmuni0 in H2.
         assert (pohrel pobm pobm0 = true /\ pohrel pobm0 (M q) = true) by easy .
         clear h2 h3 i2 i3 i4 recI.
         specialize (potrans _ _ _ H3). easy.
       - simpl in *.
         specialize (IHIPLE P h1 h2 h3 i).
         destruct i.
         simpl in *.
         destruct h2 as (h2).
         destruct h3 as (h3).
         destruct h1.
         destruct P.
         compute.
         compute in IHIPLE.
         specialize (i8 p q).
         compute in i8.
         destruct (h2 (M0 p) (M0 q)).
         simpl in *.
         rewrite i8 in IHIPLE.
         assert (pohrel (ML0 c) pobm = true /\ pohrel pobm (M0 p) = true) by easy.
         clear h2 h3 i8 i9 i10 C.
         specialize (potrans _ _ _ H0). easy.
       - simpl in *.
         specialize (IHIPLE P h1 h2 h3 i).
         destruct i.
         simpl in *.
         destruct h2 as (h2).
         destruct h3 as (h3).
         destruct h1.
         destruct P.
         compute.
         compute in IHIPLE.
         specialize (i8 p q).
         compute in i8.
         destruct (h2 (M0 p) (M0 q)).
         simpl in *.
         rewrite i8 in IHIPLE.
         assert (pohrel (ML0 c) pobm = true /\ pohrel pobm (M0 q) = true) by easy.
         clear h2 h3 i8 i9 i10 C.
         specialize (potrans _ _ _ H0). easy.
       - simpl in *.
         specialize (IHIPLE1 P h1 h2 h3 i).
         specialize (IHIPLE2 P h1 h2 h3 i).
         destruct i.
         simpl in *.
         destruct h2 as (h2).
         destruct h3 as (h3).
         destruct h1.
         destruct P.
         specialize (i9 p q).
         compute in i9.
         destruct (h3 (M0 p) (M0 q)).
         simpl in *.
         rewrite i9 in IHIPLE1.
         compute in hiapp.
         destruct (h2 hi (M0 p)).
         simpl in *.
         specialize (pobmuni (ML0 c)).
         assert ( pohrel (ML0 c) hi = true /\ pohrel (ML0 c) (M0 p) = true) by easy.
         apply pobmuni in H1.
         assert (pohrel (ML0 c) pobm = true /\ pohrel pobm (M0 q) = true) by easy.
         clear h2 h3 i8 i9 i10 hiob C.
         specialize (potrans _ _ _ H2). easy.
Qed.


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

(** This module contains lemmas related to tight typing [G ⊢# t: T] *)

Set Implicit Arguments.

Require Import Definitions PreciseTyping.

(** * Tight typing [G |-# t: T] *)

Reserved Notation "G '⊢#' t ':' T" (at level 40, t at level 59).
Reserved Notation "G '⊢#' T '<:' U" (at level 40, T at level 59).

(** *** Tight term typing [G ⊢# t: T] *)
(** Tight typing is very similar to general typing, and could be obtained by replacing
    all occurrences of [⊢] with [⊢#], except for the following:
    - in the type selection subtyping rules Sel-<: and <:-Sel ([subtyp_sel1] and [subtyp_sel2]),
      the premise is precise typing of a type declaration with equal bounds;
    - whenever a typing judgement in a premise extends the environment (for example, [ty_all_intro_t]),
      it is typed under general typing [⊢] and not tight typing [⊢#]. *)

Inductive ty_trm_t : ctx -> trm -> typ -> Prop :=

(** [G(x) = T]   #
#
    [――――――――――] #
#
    [G ⊢# x: T]  *)
| ty_var_t : forall G x T,
    binds x T G ->
    G ⊢# trm_var (avar_f x) : T

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

(** [G ⊢# x: forall(S)T] #
#
    [G ⊢# z: S]     #
#
    [――――――――――――――] #
#
    [G ⊢# x z: T^z]     *)
| ty_all_elim_t : forall G x z S T,
    G ⊢# trm_var (avar_f x) : typ_all S T ->
    G ⊢# trm_var (avar_f z) : S ->
    G ⊢# trm_app (avar_f x) (avar_f z) : open_typ z T

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

(** [G ⊢# x: {a: T}] #
#
    [―――――――――――――――] #
#
    [G ⊢# x.a: T]        *)
| ty_new_elim_t : forall G x a T,
    G ⊢# trm_var (avar_f x) : typ_rcd (dec_trm a T) ->
    G ⊢# trm_sel (avar_f x) a : T

(** [G ⊢# t: T]             #
#
    [G, x: T ⊢ u^x: U]       #
#
    [x fresh]                #
#
    [――――――――――――――――]       #
#
    [G ⊢# let t in u: U]        *)
| ty_let_t : forall L G t u T U,
    G ⊢# t : T ->
    (forall x, x \notin L ->
      G & x ~ T ⊢ open_trm x u : U) ->
    G ⊢# trm_let t u : U

(** [G ⊢# x: T^x]   #
#
    [――――――――――――――] #
#
    [G ⊢# x: mu(T)] *)
| ty_rec_intro_t : forall G x T,
    G ⊢# trm_var (avar_f x) : open_typ x T ->
    G ⊢# trm_var (avar_f x) : typ_bnd T

(** [G ⊢# x: mu(T)] #
#
    [――――――――――――――] #
#
    [G ⊢# x: T^x]       *)
| ty_rec_elim_t : forall G x T,
    G ⊢# trm_var (avar_f x) : typ_bnd T ->
    G ⊢# trm_var (avar_f x) : open_typ x T

(** [G ⊢# x: T]      #
#
    [G ⊢# x: U]      #
#
    [―――――――――――――]   #
#
    [G ⊢# x: T /\ U]      *)
| ty_and_intro_t : forall G x T U,
    G ⊢# trm_var (avar_f x) : T ->
    G ⊢# trm_var (avar_f x) : U ->
    G ⊢# trm_var (avar_f x) : typ_and T U

(** [G ⊢# t: T]    #
#
    [G ⊢# T <: U]  #
#
    [―――――――――――――] #
#
    [G ⊢# t: U]        *)
| ty_sub_t : forall G t T U,
    G ⊢# t : T ->
    G ⊢# T <: U ->
    G ⊢# t : U
where "G '⊢#' t ':' T" := (ty_trm_t G t T)

(** *** Tight subtyping [G ⊢# T <: U] *)
with subtyp_t : ctx -> typ -> typ -> Prop :=

(** [G ⊢# T <: top] *)
| subtyp_top_t: forall G T,
    G ⊢# T <: typ_top

(** [G ⊢# bot <: T] *)
| subtyp_bot_t: forall G T,
    G ⊢# typ_bot <: T

(** [G ⊢# T <: T] *)
| subtyp_refl_t: forall G T,
    G ⊢# T <: T

(** [G ⊢# S <: T]     #
#
    [G ⊢# T <: U]     #
#
    [―――――――――――――]    #
#
    [G ⊢# S <: U]         *)
| subtyp_trans_t: forall G S T U,
    G ⊢# S <: T ->
    G ⊢# T <: U ->
    G ⊢# S <: U

(** [G ⊢# T /\ U <: T] *)
| subtyp_and11_t: forall G T U,
    G ⊢# typ_and T U <: T

(** [G ⊢# T /\ U <: U] *)
| subtyp_and12_t: forall G T U,
    G ⊢# typ_and T U <: U

(** [G ⊢# S <: T]       #
#
    [G ⊢# S <: U]       #
#
    [――――――――――――――――]   #
#
    [G ⊢# S <: T /\ U]       *)
| subtyp_and2_t: forall G S T U,
    G ⊢# S <: T ->
    G ⊢# S <: U ->
    G ⊢# S <: typ_and T U

(** [G ⊢# T <: U]           #
#
    [――――――――――――――――――――――] #
#
    [G ⊢# {a: T} <: {a: U}]     *)
| subtyp_fld_t: forall G a T U,
    G ⊢# T <: U ->
    G ⊢# typ_rcd (dec_trm a T) <: typ_rcd (dec_trm a U)

(** [G ⊢# S2 <: S1]                   #
#
    [G ⊢# T1 <: T2]                   #
#
    [――――――――――――――――――――――――――――――――] #
#
    [G ⊢# {A: S1..T1} <: {A: S2..T2}]     *)
| subtyp_typ_t: forall G A S1 T1 S2 T2,
    G ⊢# S2 <: S1 ->
    G ⊢# T1 <: T2 ->
    G ⊢# typ_rcd (dec_typ A S1 T1) <: typ_rcd (dec_typ A S2 T2)

(** [G ⊢! x: {A: T..T}] #
#
    [――――――――――――――――――] #
#
    [G ⊢# T <: x.A]         *)
| subtyp_sel2_t: forall G x A T U,
    G ⊢! x : U ⪼ typ_rcd (dec_typ A T T) ->
    G ⊢# T <: typ_sel (avar_f x) A

(** [G ⊢! x: {A: T..T}] #
#
    [――――――――――――――――――] #
#
    [G ⊢# x.A <: T]         *)
| subtyp_sel1_t: forall G x A T U,
    G ⊢! x : U ⪼ typ_rcd (dec_typ A T T) ->
    G ⊢# typ_sel (avar_f x) A <: T

(** [G ⊢# S2 <: S1]                #
#
    [G, x: S2 ⊢ T1^x <: T2^x]       #
#
    [x fresh]                       #
#
    [――――――――――――――――――――――――]      #
#
    [G ⊢# forall(S1)T1 <: forall(S2)T2]          *)
| subtyp_all_t: forall L G S1 T1 S2 T2,
    G ⊢# S2 <: S1 ->
    (forall x, x \notin L ->
       G & x ~ S2 ⊢ open_typ x T1 <: open_typ x T2) ->
    G ⊢# typ_all S1 T1 <: typ_all S2 T2
where "G '⊢#' T '<:' U" := (subtyp_t G T U).

Hint Constructors ty_trm_t subtyp_t.

Scheme ts_ty_trm_t_mut := Induction for ty_trm_t Sort Prop
with   ts_subtyp_t     := Induction for subtyp_t Sort Prop.
Combined Scheme ts_t_mutind from ts_ty_trm_t_mut, ts_subtyp_t.

(** Tight typing implies general typing. *)
Lemma tight_to_general:
  (forall G t T,
     G ⊢# t : T ->
     G ⊢ t : T) /\
  (forall G S U,
     G ⊢# S <: U ->
     G ⊢ S <: U).
Proof.
  apply ts_t_mutind; intros; subst; eauto using precise_to_general.
Qed.


Require Import Verdi.
Require Import HandlerMonad.

Require Import UpdateLemmas.
Local Arguments update {_} {_} {_} _ _ _ _ : simpl never.

Set Implicit Arguments.

Section Counter.
  Inductive Name := primary | backup.
  Definition Name_eq_dec : forall x y : Name, {x = y} + {x <> y}.
    decide equality.
  Defined.

  Inductive Msg := inc | ack.
  Definition Msg_eq_dec : forall x y : Msg, {x = y} + {x <> y}.
    decide equality.
  Defined.

  Inductive Input := request_inc.
  Definition Input_eq_dec : forall x y : Input, {x = y} + {x <> y}.
    destruct x,y. auto.
  Defined.

  Inductive Output := inc_executed.
  Definition Output_eq_dec : forall x y : Output, {x = y} + {x <> y}.
    destruct x,y. auto.
  Defined.

  Definition Data := nat.

  Definition init_Data := 0.

  Definition Handler (S : Type) := GenHandler (Name * Msg) S Output unit.

  Definition PrimaryNetHandler (m : Msg) : Handler Data :=
    match m with
    | ack => write_output inc_executed
    | _ => nop
    end.

  Definition PrimaryInputHandler (i : Input) : Handler Data :=
    match i with
    | request_inc => modify S ;; send (backup, inc)
    end.

  Definition BackupNetHandler (m : Msg) : Handler Data :=
    match m with
    | inc => modify S ;; send (primary, ack)
    | _ => nop
    end.

  Definition BackupInputHandler (i : Input) : Handler Data := nop.

  Definition NetHandler (me : Name) (m : Msg) : Handler Data :=
    match me with
    | primary => PrimaryNetHandler m
    | backup => BackupNetHandler m
    end.

  Definition InputHandler (me : Name) (i : Input) : Handler Data :=
    match me with
    | primary => PrimaryInputHandler i
    | backup => BackupInputHandler i
    end.

  Instance Counter_BaseParams : BaseParams :=
    {
      data := Data;
      input := Input;
      output := Output
    }.

  Definition Nodes : list Name := [primary; backup].

  Lemma all_Names_Nodes : forall n, In n Nodes.
  Proof using.
    destruct n; simpl; auto.
  Qed.

  Lemma NoDup_Nodes : NoDup Nodes.
  Proof using.
    repeat constructor; simpl; intuition discriminate.
  Qed.

  Instance Counter_MultiParams : MultiParams Counter_BaseParams :=
    {
      name := Name;
      name_eq_dec := Name_eq_dec;
      msg := Msg;
      msg_eq_dec := Msg_eq_dec;
      nodes := Nodes;
      all_names_nodes := all_Names_Nodes;
      no_dup_nodes := NoDup_Nodes;
      init_handlers := fun _ => init_Data;
      net_handlers := fun dst src msg s =>
                        runGenHandler_ignore s (NetHandler dst msg);
      input_handlers := fun nm i s =>
                        runGenHandler_ignore s (InputHandler nm i)
    }.

  Lemma net_handlers_NetHandler :
    forall h src m d os d' ms,
      net_handlers h src m d = (os, d', ms) ->
      NetHandler h m d = (tt, os, d', ms).
  Proof using.
    intros.
    simpl in *.
    monad_unfold.
    repeat break_let.
    find_inversion.
    destruct u. auto.
  Qed.

  Lemma input_handlers_InputHandlers :
    forall h i d os d' ms,
      input_handlers h i d = (os, d', ms) ->
      InputHandler h i d = (tt, os, d', ms).
  Proof using.
    intros.
    simpl in *.
    monad_unfold.
    repeat break_let.
    find_inversion.
    destruct u. auto.
  Qed.

  Lemma PrimaryNetHandler_no_msgs :
    forall m d ms d' o u,
      PrimaryNetHandler m d = (u, o, d', ms) ->
      ms = [].
  Proof using.
    unfold PrimaryNetHandler.
    intros. monad_unfold.
    break_match; find_inversion; auto.
  Qed.

  Definition inc_in_flight_to_backup (l : list packet) : nat :=
    length (filterMap
              (fun p => if msg_eq_dec (pBody p) inc
                     then if name_eq_dec (pDst p) backup
                          then Some tt else None
                     else None)
              l).

  Lemma inc_in_flight_to_backup_app :
    forall xs ys,
      inc_in_flight_to_backup (xs ++ ys) = inc_in_flight_to_backup xs + inc_in_flight_to_backup ys.
  Proof using.
    intros.
    unfold inc_in_flight_to_backup.
    rewrite filterMap_app.
    rewrite app_length.
    auto.
  Qed.

  Lemma inc_in_flight_to_backup_cons_primary_dst :
    forall p,
      pDst p = primary ->
      inc_in_flight_to_backup [p] = 0.
  Proof using.
    intros.
    unfold inc_in_flight_to_backup.
    simpl.
    repeat break_match; try congruence; auto.
  Qed.

  Lemma inc_in_flight_to_backup_nil :
    inc_in_flight_to_backup [] = 0.
  Proof using.
    reflexivity.
  Qed.

  Lemma InputHandler_inc_in_flight_to_backup_preserved :
    forall h i d u o d' l,
      InputHandler h i d = (u, o, d', l) ->
      d' = d + inc_in_flight_to_backup (send_packets h l).
  Proof using.
    unfold InputHandler, PrimaryInputHandler, BackupInputHandler.
    simpl.
    intros.
    monad_unfold.
    repeat break_match; find_inversion; compute; auto.
    rewrite plus_comm. auto.
  Qed.

  Lemma NetHandler_inc_in_flight_to_backup_preserved :
    forall p d u o d' l,
      NetHandler (pDst p) (pBody p) d = (u, o, d', l) ->
      d' + inc_in_flight_to_backup (send_packets (pDst p) l) = d + inc_in_flight_to_backup [p].
  Proof using.
    unfold NetHandler, PrimaryNetHandler, BackupNetHandler.
    intros.
    monad_unfold.
    destruct p. simpl in *.
    repeat break_match; find_inversion; simpl; try rewrite inc_in_flight_to_backup_nil;
    unfold Data in *; compute;
    auto with *.
  Qed.

  Lemma InputHandler_backup_no_msgs :
    forall i d u o d' l,
      InputHandler backup i d = (u, o, d', l) ->
      l = [].
  Proof using.
    simpl. unfold BackupInputHandler.
    intros.
    monad_unfold.
    find_inversion.
    auto.
  Qed.

  Lemma cons_is_app :
    forall A (x : A) xs,
      x :: xs = [x] ++ xs.
  Proof using.
    auto.
  Qed.

  Lemma backup_plus_network_eq_primary :
    forall net tr,
      step_m_star (params := Counter_MultiParams) step_m_init net tr ->
      nwState net backup + inc_in_flight_to_backup (nwPackets net) = nwState net primary.
  Proof using.
    intros.
    remember step_m_init as y in *.
    revert Heqy.
    induction H using refl_trans_1n_trace_n1_ind; intros; subst.
    - reflexivity.
    - concludes.
      match goal with
      | [ H : step_m _ _ _ |- _ ] => invc H
      end; simpl.
      + find_apply_lem_hyp net_handlers_NetHandler.
        find_copy_apply_lem_hyp NetHandler_inc_in_flight_to_backup_preserved.
        repeat find_rewrite.
        rewrite cons_is_app in IHrefl_trans_1n_trace1.
        repeat rewrite inc_in_flight_to_backup_app in *.
        destruct (pDst p) eqn:?;
                 try rewrite update_same;
          try rewrite update_diff by congruence;
          unfold send_packets in *; simpl in *.
        * erewrite PrimaryNetHandler_no_msgs with (ms := l) in * by eauto.
          rewrite inc_in_flight_to_backup_cons_primary_dst in * by auto.
          simpl in *. rewrite inc_in_flight_to_backup_nil in *. auto with *.
        * omega.
      + find_apply_lem_hyp input_handlers_InputHandlers.
        find_copy_apply_lem_hyp InputHandler_inc_in_flight_to_backup_preserved.
        unfold send_packets in *. simpl in *.
        rewrite inc_in_flight_to_backup_app. subst.
        destruct h eqn:?;
                 try rewrite update_same;
          try rewrite update_diff by congruence.
        * omega.
        * erewrite InputHandler_backup_no_msgs with (l := l) by eauto.
          simpl. rewrite inc_in_flight_to_backup_nil. omega.
  Qed.

  Theorem primary_ge_backup :
    forall net tr,
      step_m_star (params := Counter_MultiParams) step_m_init net tr ->
      nwState net backup <= nwState net primary.
  Proof using.
    intros.
    apply backup_plus_network_eq_primary in H.
    auto with *.
  Qed.

  Definition trace_inputs (tr : list (name * (input + list output))) : nat :=
    length (filterMap (fun e => match e with
                             | (primary, inl i) => Some i
                             | _ => None
                             end) tr).
  Lemma trace_inputs_app :
    forall tr1 tr2,
      trace_inputs (tr1 ++ tr2) = trace_inputs tr1 + trace_inputs tr2.
  Proof using.
    unfold trace_inputs.
    intros.
    rewrite filterMap_app.
    rewrite app_length. auto.
  Qed.

  Definition trace_outputs (tr : list (name * (input + list output))) : nat :=
    length (filterMap (fun e => match e with
                             | (primary, inr [o]) => Some o
                             | _ => None
                             end) tr).

  Lemma trace_outputs_app :
    forall tr1 tr2,
      trace_outputs (tr1 ++ tr2) = trace_outputs tr1 + trace_outputs tr2.
  Proof using.
    unfold trace_outputs.
    intros.
    rewrite filterMap_app.
    rewrite app_length. auto.
  Qed.

  Definition ack_in_flight_to_primary (l : list packet) : nat :=
    length (filterMap
              (fun p => if msg_eq_dec (pBody p) ack
                     then if name_eq_dec (pDst p) primary
                          then Some tt else None
                     else None)
              l).

  Lemma ack_in_flight_to_primary_app :
    forall xs ys,
      ack_in_flight_to_primary (xs ++ ys) = ack_in_flight_to_primary xs + ack_in_flight_to_primary ys.
  Proof using.
    unfold ack_in_flight_to_primary.
    intros.
    rewrite filterMap_app.
    rewrite app_length. auto.
  Qed.

  Lemma ack_in_flight_to_primary_backup :
    forall p,
      pDst p = backup ->
      ack_in_flight_to_primary [p] = 0.
  Proof using.
    intros.
    unfold ack_in_flight_to_primary.
    simpl.
    repeat break_match; try congruence; auto.
  Qed.

  Lemma InputHandler_trace_preserved :
    forall h i d u o d' l,
      InputHandler h i d = (u, o, d', l) ->
      trace_inputs [(h, inl i)] =
      trace_outputs [(h, inr o)] +
      inc_in_flight_to_backup (send_packets h l) +
      ack_in_flight_to_primary (send_packets h l).
  Proof using.
    unfold InputHandler, PrimaryInputHandler, BackupInputHandler.
    simpl.
    intros.
    monad_unfold.
    repeat break_match; find_inversion; compute; auto.
  Qed.

  Lemma NetHandler_trace_preserved :
    forall p d u o d' l,
      NetHandler (pDst p) (pBody p) d = (u, o, d', l) ->
      inc_in_flight_to_backup [p] +
      ack_in_flight_to_primary [p] =
      trace_outputs [((pDst p), inr o)] +
      inc_in_flight_to_backup (send_packets (pDst p) l) +
      ack_in_flight_to_primary (send_packets (pDst p) l).
  Proof using.
    unfold NetHandler, PrimaryNetHandler, BackupNetHandler.
    intros.
    monad_unfold.
    destruct p. simpl in *.
    repeat break_match; find_inversion; simpl; try rewrite inc_in_flight_to_backup_nil;
    unfold Data in *; compute;
    auto with *.
  Qed.

  Lemma trace_inputs_output :
    forall h os,
      trace_inputs [(h, inr os)] = 0.
  Proof using.
    intros.
    unfold trace_inputs.
    simpl. repeat break_match; simpl; congruence.
  Qed.

  Lemma trace_outputs_input :
    forall h i,
      trace_outputs [(h, inl i)] = 0.
  Proof using.
    intros.
    unfold trace_outputs.
    simpl. repeat break_match; simpl; congruence.
  Qed.

  Lemma trace_outputs_backup :
    forall e,
      trace_outputs [(backup, e)] = 0.
  Proof using.
    auto.
  Qed.

  Lemma inputs_eq_outputs_plus_inc_plus_ack :
    forall net tr,
      step_m_star (params := Counter_MultiParams) step_m_init net tr ->
      trace_inputs tr = trace_outputs tr +
                        inc_in_flight_to_backup (nwPackets net) +
                        ack_in_flight_to_primary (nwPackets net).
  Proof using.
    intros.
    remember step_m_init as y in *.
    revert Heqy.
    induction H using refl_trans_1n_trace_n1_ind; intros; subst.
    - reflexivity.
    - concludes.
      match goal with
      | [ H : step_m _ _ _ |- _ ] => invc H
      end; simpl.
      + find_apply_lem_hyp net_handlers_NetHandler.
        repeat find_rewrite.
        rewrite trace_inputs_app.
        rewrite trace_outputs_app.
        rewrite cons_is_app with (x := p) in *.
        repeat rewrite inc_in_flight_to_backup_app in *.
        repeat rewrite ack_in_flight_to_primary_app in *.
        find_apply_lem_hyp NetHandler_trace_preserved.
        destruct (pDst p) eqn:?.
        * erewrite inc_in_flight_to_backup_cons_primary_dst in * by eauto.
          rewrite trace_inputs_output in *. simpl in  *. omega.
        * rewrite ack_in_flight_to_primary_backup in * by auto.
          rewrite trace_outputs_backup in *. unfold send_packets in *.
          simpl in *. rewrite <- plus_n_O in *. omega.
      + find_apply_lem_hyp input_handlers_InputHandlers.
        find_apply_lem_hyp InputHandler_trace_preserved.
        rewrite cons_is_app.
        repeat rewrite trace_inputs_app.
        repeat rewrite trace_outputs_app.
        repeat rewrite inc_in_flight_to_backup_app in *.
        repeat rewrite ack_in_flight_to_primary_app in *.
        rewrite trace_outputs_input.
        rewrite trace_inputs_output.
        unfold send_packets in *. simpl in *. omega.
  Qed.

  Theorem inputs_ge_outputs :
    forall net tr,
      step_m_star (params := Counter_MultiParams) step_m_init net tr ->
      trace_outputs tr <= trace_inputs tr.
  Proof using.
    intros.
    apply inputs_eq_outputs_plus_inc_plus_ack in H.
    omega.
  Qed.
End Counter.


Ltac eval1 :=
unfold sf_red;
match goal with
| |- multi_step sf_red1  (App (App (App (App _ _) _) _) _) _ =>
eapply transitive_red; [eapply preserves_app_sf_red ; [eval1 |]|]
| |- multi_step sf_red1  (App (App (App (Op Node) (Op Node)) _) _) _ =>
  eapply succ_red; [eapply2 k_red |]
| |- multi_step sf_red1  (App (App (App (Op Node) (App (Op Node) _)) _) _) _ =>
  eapply succ_red; [eapply2 s_red |]
| |- multi_step sf_red1  (App (App (App (Op Node) (App (App (Op Node) _) _)) _) _) _ =>
  eapply succ_red; [eapply2 f_red |]
| |- multi_step sf_red1  (App (App (Op Node) _) _) _ => eapply transitive_red; [eapply preserves_app_sf_red ; eval1 |]
| |- multi_step sf_red1  (App (Op Node) _) _ => eapply transitive_red; [eapply preserves_app_sf_red ; [auto|eval1 ]|]
| _ => auto
end.

Definition s_op :=
star (star (star (App (App (Ref 2) (Ref 0))
                                  (App (Ref 1) (Ref 0))))).

(* s_opt rule takes 11 steps *)

Lemma s_op_rule : forall M N P, sf_red (App (App (App s_op M) N) P) (App (App M P) (App N P)).
Proof.
intros; unfold s_op; simpl; unfold_op; simpl.
eval1. eval1. eval1. auto.  eval1. eval1. auto. eval1. eval1. eval1. auto.  eval1. eval1. auto.  eval1. eval1. eval1.
 auto. eval1. eval1. auto.  eval1. eval1. eval1. auto. eval1. auto. auto.  eval1. eval1. auto.  eval1.
auto.  auto. auto. auto.
 eval1. eval1. eval1. auto.
eval1. eval1. auto.  eval1. eval1. eval1. auto. eval1. auto. auto.  eval1. auto. auto. auto. auto.
  eval1. eval1. eval1. auto. eval1. auto. auto. eval1. auto. auto. auto. auto. auto. auto.
eval1. eval1. auto.  eval1. eval1. eval1. auto. eval1. auto. auto.  eval1. auto. auto.
 eval1. auto.  eval1. eval1. auto.  eval1.  eval1. eval1. auto.  eval1. eval1. auto. eval1. eval1. eval1. auto. eval1.
eval1. auto. eval1. eval1. eval1. auto. eval1. eval1. auto. eval1. eval1. eval1. auto.  eval1.
auto. auto. eval1. auto. auto. auto. auto.  eval1. eval1. eval1. auto. eval1. auto. auto.  eval1. auto.
auto. auto. auto. auto.  eval1.  eval1. eval1. auto.  eval1. eval1. auto.  eval1. eval1.  eval1.  auto.
eval1. eval1. auto.  eval1. eval1.  eval1. auto. eval1. auto. auto.  eval1. auto. auto. auto. auto.
 eval1. eval1. eval1. auto.  eval1. all: auto.
 eval1. eval1. eval1.  eval1. auto. eval1. eval1. auto. eval1. eval1. eval1. auto.
(* 100 steps *)
 eval1. eval1. auto.  eval1. eval1. eval1. auto.  eval1.
eval1. auto. eval1. eval1. eval1. auto.  eval1. eval1. auto. eval1. eval1. eval1. auto. eval1. eval1. auto.
eval1. all: auto.
 eval1. eval1. eval1. eval1. auto. eval1. all:auto.
 eval1. eval1. auto. eval1. eval1.
eval1. eval1. auto. eval1. all: auto.
(* 1 *)
eapply transitive_red; [eapply preserves_app_sf_red ; [eval1 |]|].
eval1. auto.  eval1. eval1.  eval1. eval1. auto. eval1. eval1. auto.
eval1. eval1. eval1. auto. eval1. eval1. auto. eval1. eval1. eval1. auto.
eval1. eval1. all: auto.
 eval1. eval1. eval1. auto. eval1. eval1. eval1. eval1. all: auto.
eval1. eval1. eval1. eval1. eval1. auto. eval1. all: auto.
eval1. eval1. eval1. auto. eval1. eval1. eval1. eval1. all: auto.
(* 68 steps *)
(* 1 *)
eapply transitive_red.
eapply preserves_app_sf_red.
eapply preserves_app_sf_red.
eapply preserves_app_sf_red.
eapply preserves_app_sf_red. auto.
eval1. eval1. eval1. eval1. eval1. eval1. auto.  eval1. auto. auto. eval1. auto. auto. auto.
eval1. auto.  eval1. eval1. eval1. auto.  eval1. auto. auto.  auto. eval1. eval1. auto.
eval1. auto. auto. auto. eval1. auto. eval1. auto. eval1. auto. eval1. auto. eval1. auto. eval1.
auto.  eval1. auto.
eapply transitive_red.
eapply preserves_app_sf_red.
eapply preserves_app_sf_red.
eapply preserves_app_sf_red.
eapply preserves_app_sf_red. auto.
eval1. auto.  eval1. auto. auto. auto.  eval1. auto. auto. auto.  eval1. eval1. eval1. auto.
  eval1. auto. auto. eval1. auto. auto. auto.
eapply transitive_red.
eapply preserves_app_sf_red.
eapply preserves_app_sf_red.
eapply preserves_app_sf_red. auto.
eval1. eval1. eval1. eval1. eval1. auto. eval1. eval1. auto. eval1. eval1. eval1. auto.
eval1. eval1. auto.  eval1. eval1.  eval1.  auto. eval1.  auto.  auto. eval1. auto. auto. auto.
auto.  eval1. eval1. eval1. auto. eval1. auto. auto. eval1. all: auto.
eval1. eval1. auto. eval1. eval1. auto. auto. eval1.
eapply2 preserves_app_sf_red.
eapply transitive_red.
eapply preserves_app_sf_red.
eapply preserves_app_sf_red.
eapply preserves_app_sf_red. auto.
eval1. eval1. eval1. eval1. eval1. auto. eval1. auto. auto.  eval1. auto. auto. auto.  eval1. auto. eval1.
 eval1. auto. eval1. auto. auto. auto.  eval1. eval1. eval1. auto.  eval1. eval1.  auto. eval1.
eval1. eval1. auto. eval1. auto. auto. eval1. auto. auto. auto. auto.
eval1. eval1. eval1. auto. eval1. auto. auto. eval1. auto. auto. auto. auto.
eval1. eval1.  auto. eval1. auto. auto. auto.
eapply transitive_red.
eapply preserves_app_sf_red.
eapply preserves_app_sf_red.
eapply preserves_app_sf_red.
eapply preserves_app_sf_red. auto.
eval1. auto.  eval1. auto. auto. auto. eval1. auto. auto. auto. eval1. eval1. eval1.
eval1. auto. eval1. eval1. auto. eval1. eval1. eval1. auto. eval1. all: auto.
(* 100 steps *)
eval1. eval1. eval1. eval1. eval1. auto. eval1. auto. auto. eval1. auto. auto. auto.
eval1. auto. eval1. eval1. auto. auto. eval1. eval1.
eval1. auto.  eval1. all: auto.
eval1. eval1. auto.  eval1. eval1. auto. auto.
(* 18 steps *)
Qed.

Definition s_opt :=
star_opt (star_opt (star_opt (App (App (Ref 2) (Ref 0))
                                  (App (Ref 1) (Ref 0))))).

(* s_opt rule takes 11 steps *)

Lemma s_opt_rule : forall M N P, sf_red (App (App (App s_opt M) N) P) (App (App M P) (App N P)).
Proof.
intros; unfold s_opt. simpl. unfold_op; unfold subst; simpl.
eapply succ_red. eapply app_sf_red.  eapply app_sf_red.  eapply2 s_red. auto. auto.
eapply succ_red. eapply app_sf_red. eapply app_sf_red.  eapply app_sf_red.  eapply2 s_red.
eapply2 k_red.  auto.  auto. auto.
eapply succ_red. eapply app_sf_red. eapply app_sf_red. eapply app_sf_red.  eapply app_sf_red.  eapply2 k_red.
eapply2 s_red.  auto. auto. auto.
eapply succ_red. eapply app_sf_red.  eapply app_sf_red.  eapply app_sf_red.  eapply app_sf_red.   auto.  eapply app_sf_red.  eapply2 k_red. auto. auto. auto. auto.
eapply succ_red. eapply app_sf_red.  eapply2 s_red. auto.
eapply succ_red. eapply app_sf_red.  eapply app_sf_red.  eapply s_red. auto. auto. auto.
eapply2 k_red. auto.
eapply succ_red.   eapply app_sf_red.  eapply app_sf_red. eapply app_sf_red.   eapply2 k_red. auto. auto. auto.
eapply succ_red.  eapply s_red. all: auto.
Qed.

Lemma maxvar_occurs: forall M, maxvar M = 1 -> occurs 0 M >0.
Proof.
induction M; split_all.
gen_case H n.  omega.
assert(maxvar M1 = 1 \/ maxvar M2 = 1).
gen_case H (maxvar M1).
gen_case H (maxvar M2).
assert (max n n0 >= n) by eapply2 max_is_max.
left; omega.
inversion H0.
assert(occurs 0 M1 >0) by eapply2 IHM1. omega.
assert(occurs 0 M2 >0) by eapply2 IHM2. omega.
Qed.

(*
(* A4 *)

Definition A41 M := (star_opt (app_comb (A_k 3) (app_comb (lift 1 M) (Ref 0)))).

Lemma A4_red1: forall M, sf_red (App (A_k 4) M) (A41 M).
Proof.
intros.
replace (A_k 4) with (star_opt (star_opt (app_comb (A_k 3) (app_comb (Ref 1) (Ref 0)))))
by (unfold A_k; auto).
eapply transitive_red.
eapply2 star_opt_beta.
unfold subst.
rewrite subst_rec_preserves_star_opt.
rewrite ! subst_rec_preserves_app_comb.
rewrite subst_rec_closed.
2: rewrite A_k_closed; split_all.
unfold subst_rec.  insert_Ref_out.
eapply2 zero_red.
Qed.

Definition A42 M N := app_comb (A_k 3) (app_comb M N).

Lemma A4_red2: forall M N, sf_red (App (A41 M) N) (A42 M N).
Proof.
intros; unfold A41.
eapply transitive_red.
eapply2 star_opt_beta.
unfold subst; rewrite ! subst_rec_preserves_app_comb.
unfold lift;
rewrite subst_rec_lift_rec; try omega.
rewrite subst_rec_ref.
rewrite subst_rec_closed.
2: rewrite A_k_closed; auto.
insert_Ref_out.
unfold lift; rewrite ! lift_rec_null.
eapply2 zero_red.
Qed.

Definition A43 M N P :=  A32 (app_comb M N) P.

Lemma A4_red3: forall M N P, sf_red (App (A42 M N) P) (A43 M N P).
Proof.
intros; unfold A42.
eapply transitive_red.
eapply2 app_comb_red.
eapply transitive_red.
eapply preserves_app_sf_red.
eapply2 A3_red1. auto.
eapply2 A3_red2.
Qed.

Definition A44 M N P Q := A33 (app_comb M N) P Q.

Lemma A4_red4 : forall M N P Q,
sf_red (App (A43 M N P) Q) (A44 M N P Q).
Proof.
intros. unfold A43.
eapply2 A3_red3.
Qed.

Lemma A4_red5 : forall M N P Q R,
sf_red (App (A44 M N P Q) R) (App (App (App (App M N) P) Q) R).
Proof.
intros. unfold A44.
eapply transitive_red.
eapply2 A3_red4.
eapply transitive_red. eapply preserves_app_sf_red. eapply preserves_app_sf_red.
eapply2 app_comb_red. auto. auto. auto.
Qed.

Lemma A5_red: forall M N P Q R,
sf_red (App (App (App (App (App (A_k 5) M) N) P) Q) R) (App (App (App (App M N) P) Q) R) .
Proof.
intros.
eapply transitive_red.
eapply preserves_app_sf_red.
eapply preserves_app_sf_red.
eapply preserves_app_sf_red.
instantiate(1:= app_comb (A_k 4) (app_comb M N)).
unfold A_k; auto.
eapply transitive_red.
eapply star_opt_beta2.
unfold subst;
rewrite ! subst_rec_preserves_app_comb.
rewrite ! subst_rec_preserves_star_opt.
rewrite ! subst_rec_preserves_app_comb.
rewrite ! subst_rec_preserves_star_opt.
rewrite ! subst_rec_preserves_app_comb.
unfold subst_rec; fold subst_rec.
insert_Ref_out.
unfold subst_rec; fold subst_rec.
insert_Ref_out.
unfold lift; rewrite ! lift_rec_null.
rewrite subst_rec_lift_rec; try omega.
rewrite ! subst_rec_closed.
2: unfold_op; simpl; auto.
2: unfold_op; simpl; auto.
all: auto.
rewrite lift_rec_null. auto.
(* 1 *)
eapply transitive_red.
eapply preserves_app_sf_red.
eapply preserves_app_sf_red.
eapply2 app_comb_red.
all: auto.
eapply transitive_red.
eapply preserves_app_sf_red.
eapply preserves_app_sf_red.
eapply preserves_app_sf_red.
eapply2 A4_red1.
all: auto.
eapply transitive_red.
eapply preserves_app_sf_red.
eapply preserves_app_sf_red.
eapply2 A4_red2.
all: auto.
eapply transitive_red.
eapply preserves_app_sf_red.
eapply2 A4_red3.  all: auto.
eapply transitive_red.
 eapply2 A4_red4.
unfold A44. unfold A33.  preserves_app_sf_red.
instantiate(1:= app_comb (A_k 4) (app_comb M N)).
unfold A_k; auto.
eapply transitive_red.
eapply star_opt_beta2.
unfold subst;
rewrite ! subst_rec_preserves_app_comb.
rewrite ! subst_rec_preserves_star_opt.
rewrite ! subst_rec_preserves_app_comb.
rewrite ! subst_rec_preserves_star_opt.
rewrite ! subst_rec_preserves_app_comb.
unfold subst_rec; fold subst_rec.
insert_Ref_out.
unfold subst_rec; fold subst_rec.
insert_Ref_out.
unfold lift; rewrite ! lift_rec_null.
rewrite subst_rec_lift_rec; try omega.
rewrite ! subst_rec_closed.
2: unfold_op; simpl; auto.
2: unfold_op; simpl; auto.
all: auto.
rewrite lift_rec_null. auto.

unfold A_k; fold A_k.

*)
(*
Lemma aux :
  forall M N, occurs 0 M >0 -> maxvar N = 0 -> S (size(subst M N)) >= size M + size N.
Proof.
  induction M; split_all.
  gen_case H n. unfold subst; simpl. insert_Ref_out.
  unfold lift; rewrite lift_rec_null. omega. omega. omega.
  assert(occurs 0 M1 >0 \/ occurs 0 M2 >0) by omega.
  inversion H1.
  assert(S(size (subst M1 N)) >= size M1 + size N) by eapply2 IHM1.
  unfold subst in *.
assert(size (subst_rec M2 N 0) >= size M2). apply size_subst. ga.
*)

(* restore ?
Lemma star_bigger:
forall M, maxvar M = 0 ->
star_opt
  (star_opt
     (App (Ref 0)
        (app_comb (app_comb (app_comb M (Ref 1)) (Ref 1)) (Ref 0)))) <>
M.
Proof.
  intros.
  replace (star_opt (star_opt (App (Ref 0) (app_comb (app_comb (app_comb M (Ref 1)) (Ref 1)) (Ref 0)))))
  with
    (subst (star_opt (star_opt (App (Ref 0) (app_comb (app_comb (app_comb (Ref 2) (Ref 1)) (Ref 1)) (Ref 0))))) M) .
  intro.
elim(size_subst_star_opt (star_opt
               (App (Ref 0)
                  (app_comb (app_comb (app_comb (Ref 2) (Ref 1)) (Ref 1)) (Ref 0)))) M); intros; auto.

  unfold app_comb, star_opt; unfold_op; unfold occurs, eqnat; simpl.
intro.
omega. intro.

intros.
rewrite star_opt_occurs_true.
2: cbv. 2: omega.
2: discriminate .
unfold star_opt at 3.
unfold app_comb.
rewrite  (star_opt_occurs_true (App (Op Node) (App (Op Node) i_op))).
2: unfold app_comb; simpl; auto. 2: omega.
2: discriminate .
 rewrite  (star_opt_occurs_true (App (Op Node) (App (Op Node) (App k_op (Ref 0))))).
2: unfold app_comb; simpl; auto. 2: omega.
2: discriminate .
rewrite (star_opt_occurs_false (App k_op _)).
2: simpl; auto. 2: eapply2 occurs_closed; auto.
subst_tac.
rewrite subst_rec_closed. 2: omega.
rewrite star_opt_occurs_true.
2: simpl; auto. 2: omega. 2: discriminate.
rewrite star_opt_closed. 2: cbv; omega.
rewrite star_opt_occurs_true.
2: unfold app_comb; simpl; auto. 2: omega.
2: discriminate .
rewrite star_opt_occurs_true.
2: unfold app_comb; simpl; auto.
2: discriminate .
rewrite star_opt_occurs_true.
2: unfold app_comb; simpl; auto.
2: discriminate .
rewrite star_opt_closed.
2: cbv; auto.
rewrite star_opt_occurs_true.
2: unfold app_comb; simpl; auto.
2: discriminate .
rewrite star_opt_occurs_true.
2: unfold app_comb; simpl; auto.
2: discriminate .
rewrite star_opt_occurs_true.
2: unfold app_comb; simpl; auto.
2: discriminate .
rewrite star_opt_closed.
2: cbv; auto.
rewrite star_opt_occurs_true.
2: unfold app_comb; simpl; auto.
2: discriminate .
rewrite star_opt_occurs_true.
2: unfold app_comb; simpl; auto.
2: discriminate .
rewrite star_opt_occurs_true.
2: unfold app_comb; simpl; auto.
2: discriminate .
rewrite star_opt_occurs_true.
2: unfold app_comb; simpl; auto.
2: discriminate .
rewrite star_opt_occurs_true.
2: unfold app_comb; simpl; auto.
2: discriminate .
rewrite star_opt_occurs_true.
2: unfold app_comb; simpl; auto.
2: discriminate .
rewrite star_opt_occurs_true.
2: unfold app_comb; simpl; auto.
2: discriminate .
rewrite star_opt_occurs_true.
2: unfold app_comb; simpl; auto.
2: discriminate .
rewrite star_opt_occurs_true.
2: unfold app_comb; simpl; auto.
2: discriminate .
rewrite star_opt_closed.
2: cbv; auto.
intro. clear H.
match goal with
| H: ?M = ?N |- _ => assert(size M = size N) by congruence
end.
clear H0.
generalize H. clear H. unfold_op; unfold star_opt, occurs, size; fold size.
rewrite ! orb_false_l.
unfold_op; unfold subst, subst_rec, size; fold size.
intro; omega.
Qed.
 *)

(*
Lemma star_opt_app_comb2:
  forall M N, maxvar M = 0 -> occurs 0 N = true -> occurs 1 N = true ->
              star_opt (star_opt (app_comb M  N)) = k_op.
Proof.
  intros.
  rewrite star_opt_app_comb1; auto.
  rewrite star_opt_occurs_true.
  2: simpl; rewrite H0; auto.
  2: rewrite ! orb_false_r.
  2: replace (match N with
      | Ref 0 => subst k_op (Op Node)
      | _ =>
          App (App (Op Node) (App (Op Node) (star_opt N)))
            (App k_op (subst (App node node) (Op Node)))
      end)
    with (App (App (Op Node) (App (Op Node) (star_opt N)))
              (App k_op (subst (App node node) (Op Node)))).
  all: cycle 1.
  simpl.
  rewrite occurs_star_opt.
  rewrite H1; auto. simpl.
  rewrite orb_true_r.   auto.
  2: discriminate.
  gen2_case H0 H1 N.
  assert False.
  gen2_case H0 H1 n; discriminate. omega.
  (* 1 *)
  assert (match N with
      | Ref 0 => subst k_op (Op Node)
      | _ =>
          App (App (Op Node) (App (Op Node) (star_opt N)))
            (App k_op (subst (App node node) (Op Node)))
          end =
          App (App (Op Node) (App (Op Node) (star_opt N)))
              (App k_op (subst (App node node) (Op Node)))).
  gen2_case H0 H1 N.
  assert False.
  gen2_case H0 H1 n; discriminate. omega.
  rewrite star_opt_closed.
  2: cbv; auto.
  rewrite star_opt_occurs_true.
  2: simpl; rewrite H0; auto.
  2: rewrite ! orb_false_r.
  2: rewrite H2.
  2: simpl; auto.
  all: cycle 1.
rewrite occurs_star_opt.
rewrite H1.   simpl. rewrite orb_true_r. auto.
discriminate.
  rewrite star_opt_occurs_true.
  2: simpl; rewrite H0; auto.
  2: rewrite ! orb_false_r.
  2: rewrite H2.
  2: simpl; auto.
  all: cycle 1.
rewrite occurs_star_opt.
rewrite H1.   simpl. rewrite orb_true_r. auto.
discriminate.
  rewrite star_opt_occurs_true.
  2: simpl; rewrite H0; auto.
  2: rewrite ! orb_false_r.
  2: rewrite H2.
  2: simpl; auto.
  all: cycle 1.
rewrite occurs_star_opt.
rewrite H1.   simpl. rewrite orb_true_r. auto.
discriminate.
  rewrite star_opt_occurs_true.
  2: simpl; rewrite H0; auto.
  2: rewrite ! orb_false_r.
  2: rewrite H2.
  2: simpl; auto.
  all: cycle 1.
rewrite occurs_star_opt.
rewrite H1. auto.
discriminate.
rewrite star_opt_closed.
2: cbv; auto.
rewrite star_opt_occurs_true.
2: rewrite ! occurs_app.
2: rewrite ! occurs_op.
2: rewrite occurs_star_opt.
2: rewrite ! occurs_app. 2: rewrite H1. 2: cbv; auto. 2: discriminate.
rewrite star_opt_occurs_true.
2: rewrite ! occurs_app.
2: rewrite ! occurs_op.
2: rewrite occurs_star_opt.
2: rewrite ! occurs_app. 2: rewrite H1. 2: cbv; auto. 2: discriminate.

simpl2: rewrite H2. cbv; auto. 2: discriminate.
  2: simpl; rewrite H0; auto.
  2: rewrite ! orb_false_r.
  2: rewrite H2.
  2: simpl; auto.
  all: cycle 1.
rewrite occurs_star_opt.
rewrite H1.   simpl. rewrite orb_true_r. auto.
discriminate.
  rewrite star_opt_occurs_true.
  2: simpl; rewrite H0; auto.
  2: rewrite ! orb_false_r.
  2: rewrite H2.
  2: simpl; auto.
  all: cycle 1.
rewrite occurs_star_opt.
rewrite H1.   simpl. rewrite orb_true_r. auto.
discriminate.
  rewrite star_opt_occurs_true.
  2: simpl; rewrite H0; auto.
  2: rewrite ! orb_false_r.
  2: rewrite H2.
  2: simpl; auto.
  all: cycle 1.
rewrite occurs_star_opt.
rewrite H1.   simpl. rewrite orb_true_r. auto.
discriminate.

assert False.
  gen2_case H0 H1 n; discriminate. omega.

  2: rewrite ! orb_false_r.

  all: try discriminate.
  rewrite H0.  rewrite occurs_closed. simpl.
  unfold eqnat in *.

  2: congruence.
  rewrite star_opt_occurs_true.
  2: simpl; rewrite H0; auto. 2: congruence.
  rewrite star_opt_closed.
  2: cbv; auto.
  rewrite star_opt_occurs_true.
  2: simpl; rewrite H0; auto. 2: congruence.
  rewrite star_opt_occurs_true.
  2: simpl; rewrite H0; auto. 2: congruence.
  rewrite (star_opt_closed  (App (Op Node) (App (Op Node) i_op))).
  2: cbv; auto.
  rewrite ! (star_opt_closed (Op Node)).
  2: cbv; auto. auto.
Qed.

(*

  Lemma star_opt_app_comb:
  forall M1 N1 M2 N2, maxvar M1 = 0 -> maxvar M2 = 0 -> occurs 0 N1 = occurs 0 N2 ->
                      star_opt (app_comb M1 N1) = star_opt (app_comb M2 N2) ->
                      M1 = M2 /\ star_opt N1 = star_opt N2.
Proof.
  intros.
  assert (occurs 0 N1 = false \/ occurs 0 N1 <> false) by decide equality.
  inversion H3.
  (* 2 *)
rewrite ! star_opt_occurs_false in *.
inversion H2. split.  rewrite ! subst_rec_closed in H7. auto. omega. omega. congruence.
unfold app_comb; simpl.   rewrite H4 in *. rewrite <- H1. rewrite occurs_closed.
auto. auto. congruence.
unfold app_comb; simpl.   rewrite H4 in *. rewrite occurs_closed.
auto. auto. congruence.
(* 1 *)
generalize H2; clear H2.  unfold app_comb.
  rewrite star_opt_occurs_true at 1.
  rewrite star_opt_occurs_true at 1.
  2: unfold_op; simpl.
  2: gen_case H4 (occurs 0 N1). 2: congruence. 2: unfold_op; simpl.
  2: gen_case H4 (occurs 0 N1). 2: congruence.
  rewrite star_opt_closed at 1. 2: simpl; auto.
  rewrite star_opt_occurs_true at 1.
  2: unfold_op; simpl.
  2: gen_case H4 (occurs 0 N1). 2: congruence.
  rewrite star_opt_occurs_true at 1.
  2: unfold_op; simpl.
  2: gen_case H4 (occurs 0 N1). 2: congruence.
  unfold star_opt at 2 3.
  rewrite (star_opt_closed (App (Op Node) _)).
  2: cbv; auto.

  intro.
assert(star_opt
         (App (App (Op Node) (App (Op Node) i_op))
              (App (App (Op Node) (App (Op Node) (App k_op N2))) (App k_op M2))) =
        App
         (App (Op Node)
            (App (Op Node)
               (App (App (Op Node) (App (Op Node) (App k_op (App k_op M1))))
                  (App
                     (App (Op Node)
                        (App (Op Node)
                           (App (App (Op Node) (App (Op Node) (star_opt (App k_op N1))))
                              (App k_op (Op Node))))) (App k_op (Op Node))))))
         (App k_op (App (Op Node) (App (Op Node) i_op))) )
     by auto.
generalize H5; clear H2 H5.
assert(occurs 0 N2 = true). gen2_case H4 H1 (occurs 0 N1).
rewrite star_opt_occurs_true at 1.
  rewrite star_opt_occurs_true at 1.
  2: unfold_op; simpl.
  2:  rewrite H2; auto. 2:congruence. 2: unfold_op; simpl.
  2: rewrite H2; auto. 2: congruence.
  rewrite star_opt_closed at 1. 2: simpl; auto.
  rewrite star_opt_occurs_true at 1.
  2: unfold_op; simpl.
  2: auto.  2: congruence.
  rewrite star_opt_occurs_true at 1.
  2: unfold_op; simpl.
  2: auto. 2: congruence.
  unfold star_opt at 2 3.
  rewrite (star_opt_closed (App (Op Node) _)).
  2: cbv; auto.

  intro. inversion H5; subst.
  rewrite H2 in *.
  assert(occurs 0 N1 = true) by (gen_case H4 (occurs 0 N1)).
  rewrite H6 in *.
  split; auto.
  clear - H2 H6 H8.
  gen2_case H2 H8 N2.
  gen2_case H2 H8 n.
  gen2_case H6 H8 N1.
  gen2_case H6 H8 n0.
  all: try discriminate.
  gen2_case H6 H8 N1.
  gen2_case H6 H8 n.
  gen2_case H2 H8 (occurs 0 t).
all: try (inversion H8; fail).
all: try discriminate.
inversion H8; subst. auto.
Qed.
 *)
 *)