Require Import oeuf.Common.
Require Import oeuf.HList.
Require Import oeuf.Utopia.
Require Import oeuf.OpaqueTypes.

Inductive type :=
| ADT : type_name -> type
| Arrow : type -> type -> type
.

Definition Opaque : opaque_type_name -> type :=
    fun oty => ADT (Topaque oty).

Definition type_eq_dec (t1 t2 : type) : {t1 = t2} + {t1 <> t2}.
  decide equality; auto using type_name_eq_dec.
Defined.
Hint Resolve type_eq_dec : eq_dec.

(* Why is this not in Utopia? *)
(* Extend this if you want to extend Oeuf *)
Inductive constr_type : constr_name -> list type -> type_name -> Type :=
| CTO            : constr_type CO         []                          Tnat
| CTS            : constr_type CS         [ADT Tnat]                  Tnat

| CTtrue         : constr_type Ctrue      []                          Tbool
| CTfalse        : constr_type Cfalse     []                          Tbool

| CTnil ty       : constr_type Cnil       []                          (Tlist ty)
| CTcons ty      : constr_type Ccons      [ADT ty; ADT (Tlist ty)]    (Tlist ty)

| CTtt           : constr_type Ctt        []                          Tunit

| CTpair ty1 ty2 : constr_type Cpair      [ADT ty1; ADT ty2]          (Tpair ty1 ty2)

| CTsome ty      : constr_type Csome      [ADT ty]                    (Toption ty)
| CTnone ty      : constr_type Cnone      []                          (Toption ty)

| CTxI           : constr_type CxI        [ADT Tpositive]             Tpositive
| CTxO           : constr_type CxO        [ADT Tpositive]             Tpositive
| CTxH           : constr_type CxH        []                          Tpositive

| CTN0           : constr_type CN0        []                          TN
| CTNpos         : constr_type CNpos      [ADT Tpositive]             TN

| CTZ0           : constr_type CZ0        []                          TZ
| CTZpos         : constr_type CZpos      [ADT Tpositive]             TZ
| CTZneg         : constr_type CZneg      [ADT Tpositive]             TZ

| CTAscii       : constr_type CAscii      [ADT Tbool; ADT Tbool; ADT Tbool; ADT Tbool;ADT Tbool; ADT Tbool; ADT Tbool; ADT Tbool]   Tascii

(*| CTascii_0      : constr_type Cascii_0   []                          Tascii
| CTascii_1      : constr_type Cascii_1   []                          Tascii
| CTascii_2      : constr_type Cascii_2   []                          Tascii
| CTascii_3      : constr_type Cascii_3   []                          Tascii
| CTascii_4      : constr_type Cascii_4   []                          Tascii
| CTascii_5      : constr_type Cascii_5   []                          Tascii
| CTascii_6      : constr_type Cascii_6   []                          Tascii
| CTascii_7      : constr_type Cascii_7   []                          Tascii
| CTascii_8      : constr_type Cascii_8   []                          Tascii
| CTascii_9      : constr_type Cascii_9   []                          Tascii
| CTascii_10      : constr_type Cascii_10   []                          Tascii
| CTascii_11      : constr_type Cascii_11   []                          Tascii
| CTascii_12      : constr_type Cascii_12   []                          Tascii
| CTascii_13      : constr_type Cascii_13   []                          Tascii
| CTascii_14      : constr_type Cascii_14   []                          Tascii
| CTascii_15      : constr_type Cascii_15   []                          Tascii
| CTascii_16      : constr_type Cascii_16   []                          Tascii
| CTascii_17      : constr_type Cascii_17   []                          Tascii
| CTascii_18      : constr_type Cascii_18   []                          Tascii
| CTascii_19      : constr_type Cascii_19   []                          Tascii
| CTascii_20      : constr_type Cascii_20   []                          Tascii
| CTascii_21      : constr_type Cascii_21   []                          Tascii
| CTascii_22      : constr_type Cascii_22   []                          Tascii
| CTascii_23      : constr_type Cascii_23   []                          Tascii
| CTascii_24      : constr_type Cascii_24   []                          Tascii
| CTascii_25      : constr_type Cascii_25   []                          Tascii
| CTascii_26      : constr_type Cascii_26   []                          Tascii
| CTascii_27      : constr_type Cascii_27   []                          Tascii
| CTascii_28      : constr_type Cascii_28   []                          Tascii
| CTascii_29      : constr_type Cascii_29   []                          Tascii
| CTascii_30      : constr_type Cascii_30   []                          Tascii
| CTascii_31      : constr_type Cascii_31   []                          Tascii
| CTascii_32      : constr_type Cascii_32   []                          Tascii
| CTascii_33      : constr_type Cascii_33   []                          Tascii
| CTascii_34      : constr_type Cascii_34   []                          Tascii
| CTascii_35      : constr_type Cascii_35   []                          Tascii
| CTascii_36      : constr_type Cascii_36   []                          Tascii
| CTascii_37      : constr_type Cascii_37   []                          Tascii
| CTascii_38      : constr_type Cascii_38   []                          Tascii
| CTascii_39      : constr_type Cascii_39   []                          Tascii
| CTascii_40      : constr_type Cascii_40   []                          Tascii
| CTascii_41      : constr_type Cascii_41   []                          Tascii
| CTascii_42      : constr_type Cascii_42   []                          Tascii
| CTascii_43      : constr_type Cascii_43   []                          Tascii
| CTascii_44      : constr_type Cascii_44   []                          Tascii
| CTascii_45      : constr_type Cascii_45   []                          Tascii
| CTascii_46      : constr_type Cascii_46   []                          Tascii
| CTascii_47      : constr_type Cascii_47   []                          Tascii
| CTascii_48      : constr_type Cascii_48   []                          Tascii
| CTascii_49      : constr_type Cascii_49   []                          Tascii
| CTascii_50      : constr_type Cascii_50   []                          Tascii
| CTascii_51      : constr_type Cascii_51   []                          Tascii
| CTascii_52      : constr_type Cascii_52   []                          Tascii
| CTascii_53      : constr_type Cascii_53   []                          Tascii
| CTascii_54      : constr_type Cascii_54   []                          Tascii
| CTascii_55      : constr_type Cascii_55   []                          Tascii
| CTascii_56      : constr_type Cascii_56   []                          Tascii
| CTascii_57      : constr_type Cascii_57   []                          Tascii
| CTascii_58      : constr_type Cascii_58   []                          Tascii
| CTascii_59      : constr_type Cascii_59   []                          Tascii
| CTascii_60      : constr_type Cascii_60   []                          Tascii
| CTascii_61      : constr_type Cascii_61   []                          Tascii
| CTascii_62      : constr_type Cascii_62   []                          Tascii
| CTascii_63      : constr_type Cascii_63   []                          Tascii
| CTascii_64      : constr_type Cascii_64   []                          Tascii
| CTascii_65      : constr_type Cascii_65   []                          Tascii
| CTascii_66      : constr_type Cascii_66   []                          Tascii
| CTascii_67      : constr_type Cascii_67   []                          Tascii
| CTascii_68      : constr_type Cascii_68   []                          Tascii
| CTascii_69      : constr_type Cascii_69   []                          Tascii
| CTascii_70      : constr_type Cascii_70   []                          Tascii
| CTascii_71      : constr_type Cascii_71   []                          Tascii
| CTascii_72      : constr_type Cascii_72   []                          Tascii
| CTascii_73      : constr_type Cascii_73   []                          Tascii
| CTascii_74      : constr_type Cascii_74   []                          Tascii
| CTascii_75      : constr_type Cascii_75   []                          Tascii
| CTascii_76      : constr_type Cascii_76   []                          Tascii
| CTascii_77      : constr_type Cascii_77   []                          Tascii
| CTascii_78      : constr_type Cascii_78   []                          Tascii
| CTascii_79      : constr_type Cascii_79   []                          Tascii
| CTascii_80      : constr_type Cascii_80   []                          Tascii
| CTascii_81      : constr_type Cascii_81   []                          Tascii
| CTascii_82      : constr_type Cascii_82   []                          Tascii
| CTascii_83      : constr_type Cascii_83   []                          Tascii
| CTascii_84      : constr_type Cascii_84   []                          Tascii
| CTascii_85      : constr_type Cascii_85   []                          Tascii
| CTascii_86      : constr_type Cascii_86   []                          Tascii
| CTascii_87      : constr_type Cascii_87   []                          Tascii
| CTascii_88      : constr_type Cascii_88   []                          Tascii
| CTascii_89      : constr_type Cascii_89   []                          Tascii
| CTascii_90      : constr_type Cascii_90   []                          Tascii
| CTascii_91      : constr_type Cascii_91   []                          Tascii
| CTascii_92      : constr_type Cascii_92   []                          Tascii
| CTascii_93      : constr_type Cascii_93   []                          Tascii
| CTascii_94      : constr_type Cascii_94   []                          Tascii
| CTascii_95      : constr_type Cascii_95   []                          Tascii
| CTascii_96      : constr_type Cascii_96   []                          Tascii
| CTascii_97      : constr_type Cascii_97   []                          Tascii
| CTascii_98      : constr_type Cascii_98   []                          Tascii
| CTascii_99      : constr_type Cascii_99   []                          Tascii
| CTascii_100      : constr_type Cascii_100   []                          Tascii
| CTascii_101      : constr_type Cascii_101   []                          Tascii
| CTascii_102      : constr_type Cascii_102   []                          Tascii
| CTascii_103      : constr_type Cascii_103   []                          Tascii
| CTascii_104      : constr_type Cascii_104   []                          Tascii
| CTascii_105      : constr_type Cascii_105   []                          Tascii
| CTascii_106      : constr_type Cascii_106   []                          Tascii
| CTascii_107      : constr_type Cascii_107   []                          Tascii
| CTascii_108      : constr_type Cascii_108   []                          Tascii
| CTascii_109      : constr_type Cascii_109   []                          Tascii
| CTascii_110      : constr_type Cascii_110   []                          Tascii
| CTascii_111      : constr_type Cascii_111   []                          Tascii
| CTascii_112      : constr_type Cascii_112   []                          Tascii
| CTascii_113      : constr_type Cascii_113   []                          Tascii
| CTascii_114      : constr_type Cascii_114   []                          Tascii
| CTascii_115      : constr_type Cascii_115   []                          Tascii
| CTascii_116      : constr_type Cascii_116   []                          Tascii
| CTascii_117      : constr_type Cascii_117   []                          Tascii
| CTascii_118      : constr_type Cascii_118   []                          Tascii
| CTascii_119      : constr_type Cascii_119   []                          Tascii
| CTascii_120      : constr_type Cascii_120   []                          Tascii
| CTascii_121      : constr_type Cascii_121   []                          Tascii
| CTascii_122      : constr_type Cascii_122   []                          Tascii
| CTascii_123      : constr_type Cascii_123   []                          Tascii
| CTascii_124      : constr_type Cascii_124   []                          Tascii
| CTascii_125      : constr_type Cascii_125   []                          Tascii
| CTascii_126      : constr_type Cascii_126   []                          Tascii
| CTascii_127      : constr_type Cascii_127   []                          Tascii*)

.

Section value.
(* since these types make hlists of recursive calls, the auto-generated schemes are garbage. *)
Local Unset Elimination Schemes.

Inductive value {G : list (type * list type * type)} : type -> Type :=
| VConstr : forall {ty ctor arg_tys} (ct : constr_type ctor arg_tys ty),
        hlist (value) arg_tys ->
        value (ADT ty)
| VClose : forall {arg_ty free_tys ret_ty},
        member (arg_ty, free_tys, ret_ty) G ->
        hlist (value) free_tys ->
        value (Arrow arg_ty ret_ty)
| VOpaque : forall {oty},
        opaque_type_denote oty ->
        value (ADT (Topaque oty))
.

End value.
Implicit Arguments value.

Fixpoint type_denote (ty : type) : Type :=
  match ty with
  | ADT tyn => type_name_denote tyn
  | Arrow ty1 ty2 => type_denote ty1 -> type_denote ty2
  end.

Definition func_type_denote (fty : type * list type * type) : Type :=
    let '(arg_ty, free_tys, ret_ty) := fty in
    hlist type_denote free_tys -> type_denote arg_ty -> type_denote ret_ty.

(* Extend me if you want to extend Oeuf *)
Definition constr_denote {arg_tys ty c} (ct : constr_type c arg_tys ty) :
  hlist type_denote arg_tys -> type_denote (ADT ty) :=
  match ct with
  | CTO => fun _ => 0
  | CTS => fun h => S (hhead h)

  | CTtrue => fun _ => true
  | CTfalse => fun _ => false

  | CTnil _ => fun _ => []
  | CTcons _ => fun h => cons (hhead h) (hhead (htail h))

  | CTtt => fun _ => tt

  | CTpair _ _ => fun h => (hhead h, hhead (htail h))

  | CTsome _ => fun h => Some (hhead h)
  | CTnone _ => fun h => None

  | CTxI => fun h => xI (hhead h)
  | CTxO => fun h => xO (hhead h)
  | CTxH => fun h => xH

  | CTN0 => fun h => N0
  | CTNpos => fun h => Npos (hhead h)

  | CTZ0 => fun h => Z0
  | CTZpos => fun h => Zpos (hhead h)
  | CTZneg => fun h => Zneg (hhead h)

  | CTAscii => fun h => Ascii.Ascii ((hhead h) : bool)
                                     (hhead (htail h))
                                     (hhead (htail (htail h)))
                                     (hhead (htail (htail (htail h))))
                                     (hhead (htail (htail (htail (htail h)))))
                                     (hhead (htail (htail (htail (htail (htail h))))))
                                     (hhead (htail (htail (htail (htail (htail (htail h)))))))
                                     (hhead (htail (htail (htail (htail (htail (htail (htail h))))))))

(*  | CTascii_0 => fun _ => ascii_0
  | CTascii_1 => fun _ => ascii_1
  | CTascii_2 => fun _ => ascii_2
  | CTascii_3 => fun _ => ascii_3
  | CTascii_4 => fun _ => ascii_4
  | CTascii_5 => fun _ => ascii_5
  | CTascii_6 => fun _ => ascii_6
  | CTascii_7 => fun _ => ascii_7
  | CTascii_8 => fun _ => ascii_8
  | CTascii_9 => fun _ => ascii_9
  | CTascii_10 => fun _ => ascii_10
  | CTascii_11 => fun _ => ascii_11
  | CTascii_12 => fun _ => ascii_12
  | CTascii_13 => fun _ => ascii_13
  | CTascii_14 => fun _ => ascii_14
  | CTascii_15 => fun _ => ascii_15
  | CTascii_16 => fun _ => ascii_16
  | CTascii_17 => fun _ => ascii_17
  | CTascii_18 => fun _ => ascii_18
  | CTascii_19 => fun _ => ascii_19
  | CTascii_20 => fun _ => ascii_20
  | CTascii_21 => fun _ => ascii_21
  | CTascii_22 => fun _ => ascii_22
  | CTascii_23 => fun _ => ascii_23
  | CTascii_24 => fun _ => ascii_24
  | CTascii_25 => fun _ => ascii_25
  | CTascii_26 => fun _ => ascii_26
  | CTascii_27 => fun _ => ascii_27
  | CTascii_28 => fun _ => ascii_28
  | CTascii_29 => fun _ => ascii_29
  | CTascii_30 => fun _ => ascii_30
  | CTascii_31 => fun _ => ascii_31
  | CTascii_32 => fun _ => ascii_32
  | CTascii_33 => fun _ => ascii_33
  | CTascii_34 => fun _ => ascii_34
  | CTascii_35 => fun _ => ascii_35
  | CTascii_36 => fun _ => ascii_36
  | CTascii_37 => fun _ => ascii_37
  | CTascii_38 => fun _ => ascii_38
  | CTascii_39 => fun _ => ascii_39
  | CTascii_40 => fun _ => ascii_40
  | CTascii_41 => fun _ => ascii_41
  | CTascii_42 => fun _ => ascii_42
  | CTascii_43 => fun _ => ascii_43
  | CTascii_44 => fun _ => ascii_44
  | CTascii_45 => fun _ => ascii_45
  | CTascii_46 => fun _ => ascii_46
  | CTascii_47 => fun _ => ascii_47
  | CTascii_48 => fun _ => ascii_48
  | CTascii_49 => fun _ => ascii_49
  | CTascii_50 => fun _ => ascii_50
  | CTascii_51 => fun _ => ascii_51
  | CTascii_52 => fun _ => ascii_52
  | CTascii_53 => fun _ => ascii_53
  | CTascii_54 => fun _ => ascii_54
  | CTascii_55 => fun _ => ascii_55
  | CTascii_56 => fun _ => ascii_56
  | CTascii_57 => fun _ => ascii_57
  | CTascii_58 => fun _ => ascii_58
  | CTascii_59 => fun _ => ascii_59
  | CTascii_60 => fun _ => ascii_60
  | CTascii_61 => fun _ => ascii_61
  | CTascii_62 => fun _ => ascii_62
  | CTascii_63 => fun _ => ascii_63
  | CTascii_64 => fun _ => ascii_64
  | CTascii_65 => fun _ => ascii_65
  | CTascii_66 => fun _ => ascii_66
  | CTascii_67 => fun _ => ascii_67
  | CTascii_68 => fun _ => ascii_68
  | CTascii_69 => fun _ => ascii_69
  | CTascii_70 => fun _ => ascii_70
  | CTascii_71 => fun _ => ascii_71
  | CTascii_72 => fun _ => ascii_72
  | CTascii_73 => fun _ => ascii_73
  | CTascii_74 => fun _ => ascii_74
  | CTascii_75 => fun _ => ascii_75
  | CTascii_76 => fun _ => ascii_76
  | CTascii_77 => fun _ => ascii_77
  | CTascii_78 => fun _ => ascii_78
  | CTascii_79 => fun _ => ascii_79
  | CTascii_80 => fun _ => ascii_80
  | CTascii_81 => fun _ => ascii_81
  | CTascii_82 => fun _ => ascii_82
  | CTascii_83 => fun _ => ascii_83
  | CTascii_84 => fun _ => ascii_84
  | CTascii_85 => fun _ => ascii_85
  | CTascii_86 => fun _ => ascii_86
  | CTascii_87 => fun _ => ascii_87
  | CTascii_88 => fun _ => ascii_88
  | CTascii_89 => fun _ => ascii_89
  | CTascii_90 => fun _ => ascii_90
  | CTascii_91 => fun _ => ascii_91
  | CTascii_92 => fun _ => ascii_92
  | CTascii_93 => fun _ => ascii_93
  | CTascii_94 => fun _ => ascii_94
  | CTascii_95 => fun _ => ascii_95
  | CTascii_96 => fun _ => ascii_96
  | CTascii_97 => fun _ => ascii_97
  | CTascii_98 => fun _ => ascii_98
  | CTascii_99 => fun _ => ascii_99
  | CTascii_100 => fun _ => ascii_100
  | CTascii_101 => fun _ => ascii_101
  | CTascii_102 => fun _ => ascii_102
  | CTascii_103 => fun _ => ascii_103
  | CTascii_104 => fun _ => ascii_104
  | CTascii_105 => fun _ => ascii_105
  | CTascii_106 => fun _ => ascii_106
  | CTascii_107 => fun _ => ascii_107
  | CTascii_108 => fun _ => ascii_108
  | CTascii_109 => fun _ => ascii_109
  | CTascii_110 => fun _ => ascii_110
  | CTascii_111 => fun _ => ascii_111
  | CTascii_112 => fun _ => ascii_112
  | CTascii_113 => fun _ => ascii_113
  | CTascii_114 => fun _ => ascii_114
  | CTascii_115 => fun _ => ascii_115
  | CTascii_116 => fun _ => ascii_116
  | CTascii_117 => fun _ => ascii_117
  | CTascii_118 => fun _ => ascii_118
  | CTascii_119 => fun _ => ascii_119
  | CTascii_120 => fun _ => ascii_120
  | CTascii_121 => fun _ => ascii_121
  | CTascii_122 => fun _ => ascii_122
  | CTascii_123 => fun _ => ascii_123
  | CTascii_124 => fun _ => ascii_124
  | CTascii_125 => fun _ => ascii_125
  | CTascii_126 => fun _ => ascii_126
  | CTascii_127 => fun _ => ascii_127*)
  end.

Definition value_denote
        {G} (g : hlist func_type_denote G) :
        forall {ty}, value G ty -> type_denote ty :=
    let fix go {ty} (v : value G ty) : type_denote ty :=
        let fix go_hlist {tys} (vs : hlist (value G) tys) : hlist type_denote tys :=
            match vs with
            | hnil => hnil
            | hcons v vs => hcons (go v) (go_hlist vs)
            end in
        match v with
        | VConstr ct args => constr_denote ct (go_hlist args)
        | VClose mb free =>
                let func := hget g mb in
                let free' := go_hlist free in
                fun x => func free' x
        | VOpaque v => v
        end in @go.

Definition value_hlist_denote
        {G} (g : hlist func_type_denote G) :
        forall {tys}, hlist (value G) tys -> hlist type_denote tys :=
    let go := @value_denote G g in
    let fix go_hlist {tys} (vs : hlist (value G) tys) : hlist type_denote tys :=
        match vs with
        | hnil => hnil
        | hcons v vs => hcons (go _ v) (go_hlist vs)
        end in @go_hlist.

(* induction schemes for value *)

Definition value_rect_mut_comb G
        (P : forall {ty}, value G ty -> Type)
        (Pl : forall {tys}, hlist (value G) tys -> Type)
    (HVConstr : forall {ty ctor arg_tys} (ct : constr_type ctor arg_tys ty) args,
        Pl args -> P (VConstr ct args))
    (HVClose : forall {arg_ty free_tys ret_ty} (mb : member (arg_ty, free_tys, ret_ty) G) free,
        Pl free -> P (VClose mb free))
    (HVOpaque : forall {oty} (v : opaque_type_denote oty), P (VOpaque v))
    (Hhnil : Pl hnil)
    (Hhcons : forall {ty tys} (v : value G ty) (vs : hlist (value G) tys),
        P v -> Pl vs -> Pl (hcons v vs)) :
    (forall {ty} (v : value G ty), P v) *
    (forall {tys} (v : hlist (value G) tys), Pl v) :=
    let fix go {ty} (v : value G ty) :=
        let fix go_hlist {tys} (vs : hlist (value G) tys) :=
            match vs as vs_ return Pl vs_ with
            | hnil => Hhnil
            | hcons v vs => Hhcons v vs (go v) (go_hlist vs)
            end in
        match v as v_ return P v_ with
        | VConstr ct args => HVConstr ct args (go_hlist args)
        | VClose mb free => HVClose mb free (go_hlist free)
        | VOpaque v => HVOpaque v
        end in
    let fix go_hlist {tys} (vs : hlist (value G) tys) :=
        match vs as vs_ return Pl vs_ with
        | hnil => Hhnil
        | hcons v vs => Hhcons v vs (go v) (go_hlist vs)
        end in
    (@go, @go_hlist).

Definition value_rect_mut G P Pl HVConstr HVClose HVOpaque Hhnil Hhcons :=
    fst (value_rect_mut_comb G P Pl HVConstr HVClose HVOpaque Hhnil Hhcons).

(* dependent case analysis scheme for values *)
Lemma case_value_opaque :
  forall G o (P : value G (Opaque o) -> Type),
    (forall ov : opaque_type_denote o, P (VOpaque ov)) ->
    forall v, P v.
Proof.
  intros G o P H v.
  revert P H.
  refine (match v with
         | VConstr ct _ => _
         | VOpaque _ => _
         end).
  - destruct t; try exact idProp. inversion ct.
  - auto.
Qed.


Require Import VST.msl.base.
Require Import VST.msl.ageable.
Require Import VST.msl.sepalg.
Require Import VST.msl.sepalg_generators.
Require Import VST.msl.age_sepalg.
Require Import VST.msl.predicates_hered.
Require Import VST.msl.predicates_sl.

Local Open Scope pred.

(*Definition corable {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{agA: ageable A}{AgeA: Age_alg A}
         (P: pred A) := forall w, P w = P (core w).

Lemma corable_spec: forall {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{agA: ageable A}{AgeA: Age_alg A}
  (P: pred A),
    corable P = forall x y:A, core x = core y -> P x -> P y.
Proof.
  unfold corable; intros; apply prop_ext; split; intros.
  + rewrite H in H1 |- *.
    rewrite <- H0.
    auto.
  + pose proof core_idem w.
    pose proof (H _ _ H0).
    pose proof (H _ _ (eq_sym H0)).
    apply prop_ext; split; auto.
Qed.*)

(* from Iris: "persistent and absorbing" *)
Definition corable {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{agA: ageable A}{AgeA: Age_alg A}{EO: Ext_ord A}
         (P: pred A) := forall w, P w -> forall w', (join_sub w w' \/ join_sub w' w \/ ext_order w' w) -> P w'.

Lemma corable_core : forall {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{agA: ageable A}{AgeA: Age_alg A}{EO: Ext_ord A} P w1 w2, corable P ->
  core w1 = core w2 -> P w1 -> P w2.
Proof.
  intros.
  eapply H; [eapply H; [eassumption|]|].
  - right; left; eexists; apply core_unit.
  - left; rewrite H0; eexists; apply core_unit.
Qed.

Lemma corable_andp {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{agA: ageable A}{AgeA: Age_alg A}{EO: Ext_ord A}:
  forall P Q, corable P -> corable Q -> corable (P && Q).
Proof.
 unfold corable; intros; simpl.
 destruct H1; eauto.
Qed.
Lemma corable_orp {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{agA: ageable A}{AgeA: Age_alg A}{EO: Ext_ord A}:
  forall P Q, corable P -> corable Q -> corable (P || Q).
Proof.
 unfold corable; intros; simpl.
 destruct H1; eauto.
Qed.
Lemma corable_allp {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{agA: ageable A}{AgeA: Age_alg A}{EO: Ext_ord A}:
  forall {B: Type} (P:  B -> pred A) ,
      (forall b, corable (P b)) -> corable (allp P).
Proof.
 unfold corable; simpl; intros.
 eauto.
Qed.
Lemma corable_exp {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{agA: ageable A}{AgeA: Age_alg A}{EO: Ext_ord A}:
  forall {B: Type} (P:  B -> pred A) ,
      (forall b, corable (P b)) -> corable (exp P).
Proof.
 unfold corable; intros; simpl.
 destruct H0; eauto.
Qed.
Lemma corable_prop {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{agA: ageable A}{AgeA: Age_alg A}{EO: Ext_ord A}:
  forall P, corable (prop P).
Proof.
 unfold corable, prop; intros.
 simpl in *; auto.
Qed.

Lemma ext_later_compat {A}{agA: ageable A}{EO: Ext_ord A}: forall a b a', ext_order a b -> laterR a a' -> exists b', laterR b b' /\ ext_order a' b'.
Proof.
  intros.
  revert dependent b; induction H0; intros.
  - eapply ext_age_compat in H as (? & ? & ?); eauto.
    do 2 eexists; [|eauto].
    apply t_step; auto.
  - apply IHclos_trans1 in H as (? & ? & Hext).
    apply IHclos_trans2 in Hext as (? & ? & Hext).
    do 2 eexists; [eapply t_trans|]; eauto.
Qed.

Lemma ext_nec_compat {A}{agA: ageable A}{EO: Ext_ord A}: forall a b a', ext_order a b -> necR a a' -> exists b', necR b b' /\ ext_order a' b'.
Proof.
  intros.
  apply nec_refl_or_later in H0 as [|]; subst; eauto.
  eapply ext_later_compat in H as (? & ? & ?); eauto.
  do 2 eexists; [apply laterR_necR|]; eauto.
Qed.

Lemma corable_imp {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A} {agA: ageable A}{AgeA: Age_alg A}{EO: Ext_ord A}{EA: Ext_alg A}:
  forall P Q, corable P -> corable Q -> corable (P --> Q).
Proof.
  unfold corable; simpl; intros.
  destruct H2 as [[? J] | [[? J] | E]].
  - eapply nec_join2 in J as (? & ? & ? & Hw & ?); eauto.
    eapply ext_join_commut in H2 as (? & ? & ?); eauto.
    eapply H1 in H2; eauto.
  - eapply nec_join in J as (? & ? & ? & ? & Hw); eauto.
    eapply H1 in Hw; [| eauto | eauto].
    + eapply pred_upclosed, H0; eauto.
    + apply H with a'; eauto.
  - eapply ext_nec_compat in E as (? & Hnec & ?); eauto.
    eapply H1 in Hnec; try reflexivity.
    + eapply pred_upclosed, H0; eauto.
    + eapply pred_upclosed, H; eauto.
Qed.

Lemma corable_sepcon {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{agA: ageable A}{AgeA: Age_alg A}{EO: Ext_ord A}{EA: Ext_alg A}:
  forall P Q, corable P -> corable Q -> corable (P * Q).
Proof.
  unfold corable; simpl; intros.
  destruct H1 as (? & ? & J & HP & HQ).
  destruct H2 as [[? J'] | [[? J'] | E]].
  - destruct (join_assoc J J') as (? & ? & ?).
    do 3 eexists; eauto.
  - do 3 eexists; [apply core_unit|].
    split.
    + eapply H; [eapply H; [eassumption|]|].
      * left; eexists; apply J.
      * right; left; eapply join_sub_trans; [|eexists; eauto].
        eexists; apply core_unit.
    + eapply H0; [eapply H0; [eassumption|]|].
      * left; eexists; apply join_comm, J.
      * eauto.
  - do 3 eexists; [apply core_unit|].
    split.
    + eapply H in HP; [|left; eexists; eauto].
      eapply H in HP; [|right; right; eauto].
      eapply H; eauto.
      right; left; eexists; apply core_unit.
    + eapply H0 in HQ; [|left; eexists; eauto]; eauto.
Qed.

Lemma corable_wand: forall {A:Type} {agA:ageable A} {JA: Join A} {PA: Perm_alg A} {SaA: Sep_alg A} {XA: Age_alg A} {EO: Ext_ord A}{EA: Ext_alg A} (P Q: pred A), corable P -> corable Q -> corable (P -* Q).
Proof.
  unfold corable; simpl; intros.
  destruct H2 as [[? J] | [[? J] | E]].
  - eapply nec_join2 in J as (? & ? & J' & Hw & ?); eauto.
    eapply H1 in Hw; try apply J'; eauto.
    eapply H; [eapply H; [eapply H; [eassumption|]|]|].
    + left; eexists; apply join_comm; eassumption.
    + right; left; eexists; eauto.
    + eauto.
  - eapply nec_join in J as (? & ? & J' & ? & Hw); eauto.
    eapply H1 in Hw; try apply join_comm, core_unit.
    + eapply H0; [eapply H0; [eassumption|]|].
      * right; left; eexists; eauto.
      * left; eexists; eauto.
    + eapply H; [eapply H; [eapply H; [eapply H; [eassumption|]|]|]|].
      * left; eexists; eauto.
      * right; left; eexists; eauto.
      * left; eexists; eauto.
      * right; left; eexists; apply core_unit.
  - eapply ext_nec_compat in E as (? & Hnec & ?); eauto.
    eapply H1 in Hnec; [| apply join_comm, core_unit |].
    + eapply H0; [eapply H0; eauto|]; eauto.
    + eapply H; [|right; left; eexists; apply core_unit].
      eapply pred_upclosed; eauto.
      eapply H; [|right; left; eexists; eauto]; eauto.
Qed.

Lemma corable_later: forall {A:Type} {agA:ageable A} {JA: Join A} {PA: Perm_alg A} {SaA: Sep_alg A} {XA: Age_alg A} {EO: Ext_ord A}{EA: Ext_alg A} P, corable P -> corable (|> P).
Proof.
  unfold corable; simpl; intros.
  destruct H1 as [[? J] | [[? J] | E]].
  - eapply later_join2 in J as (? & ? & ? & ? & ?); eauto.
  - eapply later_join in J as (? & ? & ? & ? & ?); eauto.
    eapply H; eauto.
  - eapply ext_later_compat in E as (? & ? & ?); eauto.
Qed.

#[export] Hint Resolve corable_andp corable_orp corable_allp corable_exp
                    (*corable_imp*) corable_prop corable_sepcon corable_wand corable_later : core.

Lemma corable_andp_sepcon1{A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{agA: ageable A}{AgeA: Age_alg A}{EO: Ext_ord A}{EA: Ext_alg A}:
   forall P Q R, corable P ->  (P && Q) * R = P && (Q * R).
Proof.
intros.
apply pred_ext.
intros w [w1 [w2 [? [[? ?] ?]]]].
split; [eapply H; eauto|].
exists w1, w2; auto.
intros w [? [w1 [w2 [? [? ?]]]]].
exists w1; exists w2; split; [|split]; auto.
split; eauto.
Qed.

(* The following 3 lemmas should not be necessary *)
Lemma corable_andp_sepcon2{A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{agA: ageable A}{AgeA: Age_alg A}{EO: Ext_ord A}{EA: Ext_alg A}:
   forall P Q R, corable P ->  (Q && P) * R = P && (Q * R).
Proof.
intros. rewrite andp_comm. apply corable_andp_sepcon1. auto.
Qed.

Lemma corable_sepcon_andp1 {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{agA: ageable A}{AgeA: Age_alg A}{EO: Ext_ord A}{EA: Ext_alg A}:
   forall P Q R, corable P ->  Q  * (P && R) = P && (Q * R).
Proof.
intros. rewrite sepcon_comm. rewrite corable_andp_sepcon1; auto. rewrite sepcon_comm; auto.
Qed.

Lemma corable_sepcon_andp2 {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{agA: ageable A}{AgeA: Age_alg A}{EO: Ext_ord A}{EA: Ext_alg A}:
   forall P Q R, corable P ->  Q  * (R && P) = P && (Q * R).
Proof.
intros. rewrite sepcon_comm. rewrite andp_comm. rewrite corable_andp_sepcon1; auto. rewrite sepcon_comm; auto.
Qed.

(* This hint doesn't work well, hence the extra clauses in normalize1 and normalize1_in *)
#[export] Hint Rewrite @corable_andp_sepcon1 @corable_andp_sepcon2
                    @corable_sepcon_andp1 @corable_sepcon_andp2 using solve [auto with normalize typeclass_instances] : core.


Require Import SyntaxProp.
Require Import WellFormednessProp.

Theorem datarace_freedom :
  forall O H n id1 id2 this1 this2 L1 L2 Q1 Q2 l1 l2,
    wf_cfg (O, H, n) ->
    id1 <> id2 ->
    heapLookup H id1 = Some (this1, L1, Q1, EMut (ELoc l1)) ->
    heapLookup H id2 = Some (this2, L2, Q2, EMut (ELoc l2)) ->
    l1 <> l2.
Proof with eauto.
  introv wfCfg Hneq Hlookup1 Hlookup2.
  inverts wfCfg as wfH wfO Hfresh.
  inverts wfH as Hdisj wfActors.
  eapply wfActors in Hlookup1 as wfActor1.
  eapply wfActors in Hlookup2 as wfActor2.
  inverts wfActor1 as _ _ _ _ Hloc1 _ _.
  inverts wfActor2 as _ _ _ _ Hloc2 _ _.
  simpls.
  assert (In l1 L1) as HIn1...
  assert (In l2 L2) as HIn2...
  assert (LH H id1 = Some L1) as HLH1
      by (unfolds; rewrite Hlookup1; eauto).
  assert (LH H id2 = Some L2) as HLH2
      by (unfolds; rewrite Hlookup2; eauto).
  specializes Hdisj id1 id2 L1 L2 Hneq.
Qed.


Require Forcing.

Section Eq.

Variable Obj : Type.
Variable Hom : Obj -> Obj -> Type.

Notation "P ≤ Q" := (forall R, Hom Q R -> Hom P R) (at level 70).
Notation "#" := (fun (R : Obj) (k : Hom _ R) => k).
Notation "f ∘ g" := (fun (R : Obj) (k : Hom _ R) => f R (g R k)) (at level 40).

Inductive eq {A : Type} (x : A) : A -> Type :=  eq_refl : eq x x
where "x = y :> A" := (@eq A x y) : type_scope.

Notation "x = y" := (x = y :>_) : type_scope.

Forcing Translate eq using Obj Hom.

Definition eq_rec_ p
         (A P : forall p0 : Obj, p ≤ p0 -> forall p1 : Obj, p0 ≤ p1 -> Type)
         (x : forall (p0 : Obj) (α : p ≤ p0),
      A p0 α p0 #)
      (Hrefl : forall (p0 : Obj) (α : p ≤ p0), P p0 α p0 #)
      (y:forall (p0 : Obj) (α : p ≤ p0),
          A p0 α _ #)
      (e : eqᶠ p A x y) : P p # p # :=
  match e with eq_reflᶠ _ _ _ => Hrefl p # end.

Definition eq_rec_nd A (x : A) (P : Type) (p : P) y (e : x = y) : P := match e with eq_refl _ => p end.

Forcing Translate eq_rec_nd using Obj Hom.

Definition eq_mem : forall A x R, forall y, x = y ->
                                  (forall y, x = y -> R) -> R :=
  fun A x (R : Type) =>
    eq_rec_nd A x ((forall y, x = y -> R) -> R) (fun f => f x (eq_refl x)).

Forcing Translate eq_mem using Obj Hom.

Forcing Definition eq_rect' : forall A (x :A) (P : forall y, x = y -> Type),
    (* eq_mem _ _ _ _ (eq_refl x) P -> *)
    P x (eq_refl x) ->
    forall y (e:x = y), eq_mem _ _ _ _ e P using Obj Hom.
Proof.

    intros p A x P P_refl y e.

pose (Type_of_A := fun p => forall p0 : Obj, p ≤ p0 -> forall p : Obj, p0 ≤ p -> Type).
  pose (Type_of_x := fun p (A:Type_of_A p) => forall p0 (α: p ≤ p0), A p0 α p0 #).
  pose (Type_of_P := fun p (A:Type_of_A p) (x:Type_of_x p A) =>
                       forall (p0 : Obj) (α : p ≤ p0)
        (y : forall (p : Obj) (α0 : p0 ≤ p), A p (α ∘ α0) p #),
      (forall (p : Obj) (α0 : p0 ≤ p),
       eqᶠ p
         (fun (p1 : Obj) (α1 : p ≤ p1) =>
          A p1 (fun (R : Obj) (k : Hom p1 R) => α R (α0 R (α1 R k))))
         (fun (p1 : Obj) (α1 : p ≤ p1) =>
          x p1 (fun (R : Obj) (k : Hom p1 R) => α R (α0 R (α1 R k))))
         (fun (p1 : Obj) (α1 : p ≤ p1) => y p1 (α0 ∘ α1))) ->
      forall p : Obj, p0 ≤ p -> Type).
  pose (Type_of_P_refl := fun p (A:Type_of_A p) (x:Type_of_x p A) (P:Type_of_P p A x) =>
      forall (p0 : Obj) (α : p ≤ p0),
         eq_memᶠ p0 (fun (p : Obj) (α0 : p0 ≤ p) => A p (α ∘ α0))
           (fun (p : Obj) (α0 : p0 ≤ p) => x p (α ∘ α0))
           (fun (p : Obj) (_ : p0 ≤ p) (p1 : Obj) (_ : p ≤ p1) =>
            forall p2 : Obj, p1 ≤ p2 -> Type)
           (fun (p : Obj) (α0 : p0 ≤ p) => x p (α ∘ α0))
           (fun (p : Obj) (α0 : p0 ≤ p) =>
            eq_reflᶠ p
              (fun (p1 : Obj) (α1 : p ≤ p1) =>
               A p1 (fun (R : Obj) (k : Hom p1 R) => α R (α0 R (α1 R k))))
              (fun (p1 : Obj) (α1 : p ≤ p1) =>
               x p1 (fun (R : Obj) (k : Hom p1 R) => α R (α0 R (α1 R k)))))
           (fun (p : Obj) (α0 : p0 ≤ p) => P p (α ∘ α0)) p0
           #).
  pose (Goal_Type := fun  p (A:Type_of_A p) (x:Type_of_x p A) (P:Type_of_P p A x)
              (P_refl : Type_of_P_refl p A x P) y
              (e0 : eqᶠ p A x y ) =>
                       eq_rec_ p
     (fun (p0 : Obj) (α : p ≤ p0) =>
      A p0 (fun (R : Obj) (k : Hom p0 R) => α R k))
     (fun (p0 : Obj) (α : p ≤ p0) (p1 : Obj) (α0 : p0 ≤ p1) =>
      (forall (p2 : Obj) (α1 : p1 ≤ p2)
         (y0 : forall (p3 : Obj) (α2 : p2 ≤ p3),
               A p3
                 (fun (R : Obj) (k : Hom p3 R) =>
                  α R (α0 R (α1 R (α2 R k)))) p3
                 #),
       (forall (p3 : Obj) (α2 : p2 ≤ p3),
        eqᶠ p3
          (fun (p4 : Obj) (α3 : p3 ≤ p4) =>
           A p4
             (fun (R : Obj) (k : Hom p4 R) =>
              α R (α0 R (α1 R (α2 R (α3 R k))))))
          (fun (p4 : Obj) (α3 : p3 ≤ p4) =>
           x p4
             (fun (R : Obj) (k : Hom p4 R) =>
              α R (α0 R (α1 R (α2 R (α3 R k))))))
          (fun (p4 : Obj) (α3 : p3 ≤ p4) => y0 p4 (α2 ∘ α3)) )
       -> forall p3 : Obj, p2 ≤ p3 -> Type) ->
      forall p2 : Obj, p1 ≤ p2 -> Type)
     (fun (p0 : Obj) (α : p ≤ p0) =>
      x p0 (fun (R : Obj) (k : Hom p0 R) => α R k))
     (fun (p0 : Obj) (α : p ≤ p0)
        (f : forall (p1 : Obj) (α0 : p0 ≤ p1)
               (y0 : forall (p2 : Obj) (α1 : p1 ≤ p2),
                     A p2
                       (fun (R : Obj) (k : Hom p2 R) =>
                        α R (α0 R (α1 R k))) p2 #),
             (forall (p2 : Obj) (α1 : p1 ≤ p2),
              eqᶠ p2
                (fun (p3 : Obj) (α2 : p2 ≤ p3) =>
                 A p3
                   (fun (R : Obj) (k : Hom p3 R) =>
                    α R (α0 R (α1 R (α2 R k)))))
                (fun (p3 : Obj) (α2 : p2 ≤ p3) =>
                 x p3
                   (fun (R : Obj) (k : Hom p3 R) =>
                    α R (α0 R (α1 R (α2 R k)))))
                (fun (p3 : Obj) (α2 : p2 ≤ p3) => y0 p3 (α1 ∘ α2))
                ) -> forall p2 : Obj, p1 ≤ p2 -> Type) =>
      f p0 # (fun (p1 : Obj) (α0 : p0 ≤ p1) => x p1 (α ∘ α0))
        (fun (p1 : Obj) (α0 : p0 ≤ p1) =>
         eq_reflᶠ p1
           (fun (p2 : Obj) (α1 : p1 ≤ p2) =>
            A p2 (fun (R : Obj) (k : Hom p2 R) => α R (α0 R (α1 R k))))
           (fun (p2 : Obj) (α1 : p1 ≤ p2) =>
            x p2 (fun (R : Obj) (k : Hom p2 R) => α R (α0 R (α1 R k))))))
     y e0
     (fun (p0 : Obj) (α : p ≤ p0) =>
      P p0 (fun (R : Obj) (k : Hom p0 R) => α R k)) p
     #).

  compute. set (e0 := e p #).
  clearbody e0; clear e. simpl.
  change (Goal_Type p A x P P_refl y e0).
  exact (match e0 as e1 return
               (* (match e0 with | ᶠeq_refl _ _ _ => _ end P p #)  *)
                 Goal_Type _ _ _ _ _ _ e1
                 with
            | eq_reflᶠ _ _ _ =>  P_refl p # end).
Defined.

Forcing Definition leibniz : forall A (x :A) (P : A -> Type),
    P x ->
    forall y (e:x = y), P y using Obj Hom.
Proof.
  intros p A x P P_refl y e.
  exact (match e p # in eqᶠ _ _ _ y' return P p # y' p #
         with | eq_reflᶠ _ _ _ => P_refl p # end).
Defined.

Forcing Definition eq_rect_partial_refl : forall A (x :A) (P : A -> Type)
    (a : P x), leibniz A x P a x (eq_refl _) = a using Obj Hom.
Proof.
  intros. reflexivity.
Defined.

End Eq.


(*
 * Define some inductive types  (they will be pickable)
 *)
 Require Import gherkin.
 Require Import gentree.
 Require Import String List.

Inductive containerTestType := (* a dummy type which uses some containers *)
  A: option containerTestType -> containerTestType
| B.
(* Propositional Logic *)
Inductive form := Imp (a b: form) | Var (a: nat) | And (a b: form) | Or  (a b: form) | Bot.

(* Rose Trees *)
Inductive rosetree (A: Type)  :=
| leaf:  A -> rosetree A
| node: (list (rosetree A)) -> rosetree A.

(* More fun with containers *)
Inductive containerFun (A B: Type) :=
  contMe : option ( prod (option A) (option B)) -> containerFun A B.
(* Binary Trees *)
Inductive BinTree (A: Type)  := BinNode : A -> A -> BinTree A  | BinLeaf: A -> BinTree A .

(* Binary Trees ML-Style (using prod) *)
Inductive mlBinTree2 (A: Type)  := mlBinNode2 : (prod A A) -> mlBinTree2 A.

Inductive triple (A B C: Type) := tripleC: A -> B -> C -> triple A B C.
Inductive tripleAsContainer (A: Type) :=
  tcA : option (triple A nat nat) -> tripleAsContainer A
| tcB: tripleAsContainer A -> prod nat (option nat) -> tripleAsContainer A.

Inductive strangetree (C A B: Type) :=
  tCon: strangetree C B A  -> strangetree C A B |
  tLeafA: A -> strangetree C A B .
Inductive listyfun A:=
  nilL: listyfun A
| one: A -> listyfun A |
consA: A -> (listyfun A) -> (listyfun A)  -> listyfun A.

Inductive doubleNat := dnO : doubleNat | dnS: doubleNat -> doubleNat -> doubleNat.
Inductive strangeInd (A: Type) := s0: A -> A -> A -> A -> A -> strangeInd A.
Inductive specialtriple (A: Type) := spt: A -> A -> A -> specialtriple A.
(* uniform: 2 , nonuniform: 3*)
Inductive mix (A B C D E: Type) := mixA: mix A B C E D -> mix A B C D E.

Inductive mixl (A B C D E F G H I: Type) := mixAl: mixl A B C E D I H G F -> mixl A B C D E F G H I.
Inductive inhabiNon (A: Type) := asimpl2:  inhabiNon A.
Inductive selfreference (A: Type) := sA: A -> selfreference A -> selfreference A.
Inductive selfreference' (A: Type) := sA':  selfreference' A -> A ->  selfreference' A.
Inductive tType := tA | tB | tC | tD.
Inductive inhabited (A: Type) := asimpl: A -> inhabited A.

(** These types can not be pickled just yet **)

Inductive Vector A: nat -> Type :=
| nilV: Vector A 0
| consV (n: nat): A -> Vector A n -> Vector A (S n).

Inductive Countdown : nat -> Type :=
| initCtr: Countdown 1000
| downCtr: forall n,Countdown (S n) -> Countdown n.
(** The plugin also does *not* support mutual inductive types **)
Inductive tree (A B: Type) := Tnode : A -> forest A B -> tree A B
with forest (A B: Type) :=
| Fleaf : B -> forest A B
| Fcons : tree A B -> forest A B -> forest A B.

MetaCoq Run Derive Pickle for nat.

MetaCoq Run Derive Pickle for bool.
MetaCoq Run Derive Pickle for form.
MetaCoq Run Derive Pickle for option.
MetaCoq Run Derive Pickle for prod.
MetaCoq Run Derive Pickle for strangetree.
MetaCoq Run Derive Pickle for list.
MetaCoq Run Derive Pickle for Ntree.
MetaCoq Run Derive Pickle for triple.
MetaCoq Run Derive Pickle for listyfun.
MetaCoq Run Derive Pickle for mlBinTree2.
MetaCoq Run Derive Pickle for mix.
MetaCoq Run Derive Pickle for tripleAsContainer.
MetaCoq Run Derive Pickle for rosetree.
MetaCoq Run Derive Pickle for strangeInd.
MetaCoq Run Derive Pickle for doubleNat.
MetaCoq Run Derive Pickle for specialtriple.

(* MetaCoq Run Derive pickle for containerFun with [<% option %>; <% prod %>]. *)

MetaCoq Run Derive Unpickle for nat.
MetaCoq Run Derive Unpickle for bool.
MetaCoq Run Derive Unpickle for form.
MetaCoq Run Derive Unpickle for option.
MetaCoq Run Derive Unpickle for prod.
MetaCoq Run Derive Unpickle for strangetree.
MetaCoq Run Derive Unpickle for list.
MetaCoq Run Derive Unpickle for Ntree.
MetaCoq Run Derive Unpickle for triple.
MetaCoq Run Derive Unpickle for listyfun.
MetaCoq Run Derive Unpickle for mlBinTree2.
MetaCoq Run Derive Unpickle for mix.
MetaCoq Run Derive Unpickle for tripleAsContainer.
MetaCoq Run Derive Unpickle for rosetree.
MetaCoq Run Derive Unpickle for strangeInd.
MetaCoq Run Derive Unpickle for doubleNat.
MetaCoq Run Derive Unpickle for specialtriple.

From MetaCoq.Template Require Import All.
(* Example where the automatic inference of containered types fails, but the types can be supplied manually *)
Inductive T1 := tnull : T1.
Inductive T2 := ttest : T1 -> T2.
Inductive T3 := ttest2 : T2 -> T3.

Inductive T4 := ttest3 : T3 -> T4.
Require Import List.
Import ListNotations.
MetaCoq Run (Derive pickle for T4 with [<% T1 %>; <% T2 %>; <% T3 %>]).
MetaCoq Run (Derive unpickle for T4 with [<% T1 %>; <% T2 %>; <% T3 %>]).


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

Copyright (C) 2009-2018 Sylvie Boldo
#<br />#
Copyright (C) 2009-2018 Guillaume Melquiond

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

This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
COPYING file for more details.
*)

(** * Floating-point format with abrupt underflow *)

From Coq Require Import ZArith Reals Lia.

Require Import Zaux Raux Defs Round_pred Generic_fmt Float_prop Ulp FLX.

Section RND_FTZ.

Variable beta : radix.

Notation bpow e := (bpow beta e).

Variable emin prec : Z.

Context { prec_gt_0_ : Prec_gt_0 prec }.

Inductive FTZ_format (x : R) : Prop :=
  FTZ_spec (f : float beta) :
    x = F2R f ->
    (x <> 0%R -> Zpower beta (prec - 1) <= Z.abs (Fnum f) < Zpower beta prec)%Z ->
    (emin <= Fexp f)%Z ->
    FTZ_format x.

Definition FTZ_exp e := if Zlt_bool (e - prec) emin then (emin + prec - 1)%Z else (e - prec)%Z.

(** Properties of the FTZ format *)
Global Instance FTZ_exp_valid : Valid_exp FTZ_exp.
Proof.
intros k.
unfold FTZ_exp.
generalize (Zlt_cases (k - prec) emin).
case (Zlt_bool (k - prec) emin) ; intros H1.
split ; intros H2.
lia.
split.
generalize (Zlt_cases (emin + prec + 1 - prec) emin).
case (Zlt_bool (emin + prec + 1 - prec) emin) ; intros H3.
lia.
generalize (Zlt_cases (emin + prec - 1 + 1 - prec) emin).
generalize (prec_gt_0 prec).
case (Zlt_bool (emin + prec - 1 + 1 - prec) emin) ; lia.
intros l H3.
generalize (Zlt_cases (l - prec) emin).
case (Zlt_bool (l - prec) emin) ; lia.
split ; intros H2.
generalize (Zlt_cases (k + 1 - prec) emin).
case (Zlt_bool (k + 1 - prec) emin) ; lia.
generalize (prec_gt_0 prec).
split ; intros ; lia.
Qed.

Theorem FLXN_format_FTZ :
  forall x, FTZ_format x -> FLXN_format beta prec x.
Proof.
intros x [[xm xe] Hx1 Hx2 Hx3].
eexists.
exact Hx1.
exact Hx2.
Qed.

Theorem generic_format_FTZ :
  forall x, FTZ_format x -> generic_format beta FTZ_exp x.
Proof.
intros x Hx.
cut (generic_format beta (FLX_exp prec) x).
apply generic_inclusion_mag.
intros Zx.
destruct Hx as [[xm xe] Hx1 Hx2 Hx3].
simpl in Hx2, Hx3.
specialize (Hx2 Zx).
assert (Zxm: xm <> Z0).
contradict Zx.
rewrite Hx1, Zx.
apply F2R_0.
unfold FTZ_exp, FLX_exp.
rewrite Zlt_bool_false.
apply Z.le_refl.
rewrite Hx1, mag_F2R with (1 := Zxm).
cut (prec - 1 < mag beta (IZR xm))%Z.
clear -Hx3 ; lia.
apply mag_gt_Zpower with (1 := Zxm).
apply Hx2.
apply generic_format_FLXN.
now apply FLXN_format_FTZ.
Qed.

Theorem FTZ_format_generic :
  forall x, generic_format beta FTZ_exp x -> FTZ_format x.
Proof.
intros x Hx.
destruct (Req_dec x 0) as [->|Hx3].
exists (Float beta 0 emin).
apply sym_eq, F2R_0.
intros H.
now elim H.
apply Z.le_refl.
unfold generic_format, scaled_mantissa, cexp, FTZ_exp in Hx.
destruct (mag beta x) as (ex, Hx4).
simpl in Hx.
specialize (Hx4 Hx3).
generalize (Zlt_cases (ex - prec) emin) Hx. clear Hx.
case (Zlt_bool (ex - prec) emin) ; intros Hx5 Hx2.
elim Rlt_not_ge with (1 := proj2 Hx4).
apply Rle_ge.
rewrite Hx2, <- F2R_Zabs.
rewrite <- (Rmult_1_l (bpow ex)).
unfold F2R. simpl.
apply Rmult_le_compat.
now apply IZR_le.
apply bpow_ge_0.
apply IZR_le.
apply (Zlt_le_succ 0).
apply lt_IZR.
apply Rmult_lt_reg_r with (bpow (emin + prec - 1)).
apply bpow_gt_0.
rewrite Rmult_0_l.
change (0 < F2R (Float beta (Z.abs (Ztrunc (x * bpow (- (emin + prec - 1))))) (emin + prec - 1)))%R.
rewrite F2R_Zabs, <- Hx2.
now apply Rabs_pos_lt.
apply bpow_le.
lia.
rewrite Hx2.
eexists ; repeat split ; simpl.
apply le_IZR.
rewrite IZR_Zpower.
apply Rmult_le_reg_r with (bpow (ex - prec)).
apply bpow_gt_0.
rewrite <- bpow_plus.
replace (prec - 1 + (ex - prec))%Z with (ex - 1)%Z by ring.
change (bpow (ex - 1) <= F2R (Float beta (Z.abs (Ztrunc (x * bpow (- (ex - prec))))) (ex - prec)))%R.
rewrite F2R_Zabs, <- Hx2.
apply Hx4.
apply Zle_minus_le_0.
now apply (Zlt_le_succ 0).
apply lt_IZR.
rewrite IZR_Zpower.
apply Rmult_lt_reg_r with (bpow (ex - prec)).
apply bpow_gt_0.
rewrite <- bpow_plus.
replace (prec + (ex - prec))%Z with ex by ring.
change (F2R (Float beta (Z.abs (Ztrunc (x * bpow (- (ex - prec))))) (ex - prec)) < bpow ex)%R.
rewrite F2R_Zabs, <- Hx2.
apply Hx4.
now apply Zlt_le_weak.
now apply Z.ge_le.
Qed.

Theorem FTZ_format_satisfies_any :
  satisfies_any FTZ_format.
Proof.
refine (satisfies_any_eq _ _ _ (generic_format_satisfies_any beta FTZ_exp)).
intros x.
split.
apply FTZ_format_generic.
apply generic_format_FTZ.
Qed.

Theorem FTZ_format_FLXN :
  forall x : R,
  (bpow (emin + prec - 1) <= Rabs x)%R ->
  FLXN_format beta prec x -> FTZ_format x.
Proof.
intros x Hx Fx.
apply FTZ_format_generic.
apply generic_format_FLXN in Fx.
revert Hx Fx.
apply generic_inclusion_ge.
intros e He.
unfold FTZ_exp.
rewrite Zlt_bool_false.
apply Z.le_refl.
lia.
Qed.

Theorem ulp_FTZ_0 :
  ulp beta FTZ_exp 0 = bpow (emin+prec-1).
Proof with auto with typeclass_instances.
unfold ulp; rewrite Req_bool_true; trivial.
case (negligible_exp_spec FTZ_exp).
intros T; specialize (T (emin-1)%Z); contradict T.
apply Zle_not_lt; unfold FTZ_exp; unfold Prec_gt_0 in prec_gt_0_.
rewrite Zlt_bool_true; lia.
assert (V:(FTZ_exp (emin+prec-1) = emin+prec-1)%Z).
unfold FTZ_exp; rewrite Zlt_bool_true; lia.
intros n H2; rewrite <-V.
apply f_equal, fexp_negligible_exp_eq...
lia.
Qed.

Section FTZ_round.

(** Rounding with FTZ *)
Variable rnd : R -> Z.
Context { valid_rnd : Valid_rnd rnd }.

Definition Zrnd_FTZ x :=
  if Rle_bool 1 (Rabs x) then rnd x else Z0.

Global Instance valid_rnd_FTZ : Valid_rnd Zrnd_FTZ.
Proof with auto with typeclass_instances.
split.
(* *)
intros x y Hxy.
unfold Zrnd_FTZ.
case Rle_bool_spec ; intros Hx ;
  case Rle_bool_spec ; intros Hy.
4: easy.
(* 1 <= |x| *)
now apply Zrnd_le.
rewrite <- (Zrnd_IZR rnd 0).
apply Zrnd_le...
apply Rle_trans with (-1)%R. 2: now apply IZR_le.
destruct (Rabs_ge_inv _ _ Hx) as [Hx1|Hx1].
exact Hx1.
elim Rle_not_lt with (1 := Hx1).
apply Rle_lt_trans with (2 := Hy).
apply Rle_trans with (1 := Hxy).
apply RRle_abs.
(* |x| < 1 *)
rewrite <- (Zrnd_IZR rnd 0).
apply Zrnd_le...
apply Rle_trans with 1%R.
now apply IZR_le.
destruct (Rabs_ge_inv _ _ Hy) as [Hy1|Hy1].
elim Rle_not_lt with (1 := Hy1).
apply Rlt_le_trans with (2 := Hxy).
apply (Rabs_def2 _ _ Hx).
exact Hy1.
(* *)
intros n.
unfold Zrnd_FTZ.
rewrite Zrnd_IZR...
case Rle_bool_spec.
easy.
rewrite <- abs_IZR.
intros H.
generalize (lt_IZR _ 1 H).
clear.
now case n ; trivial ; simpl ; intros [p|p|].
Qed.

Theorem round_FTZ_FLX :
  forall x : R,
  (bpow (emin + prec - 1) <= Rabs x)%R ->
  round beta FTZ_exp Zrnd_FTZ x = round beta (FLX_exp prec) rnd x.
Proof.
intros x Hx.
unfold round, scaled_mantissa, cexp.
destruct (mag beta x) as (ex, He). simpl.
assert (Hx0: x <> 0%R).
intros Hx0.
apply Rle_not_lt with (1 := Hx).
rewrite Hx0, Rabs_R0.
apply bpow_gt_0.
specialize (He Hx0).
assert (He': (emin + prec <= ex)%Z).
apply (bpow_lt_bpow beta).
apply Rle_lt_trans with (1 := Hx).
apply He.
replace (FTZ_exp ex) with (FLX_exp prec ex).
unfold Zrnd_FTZ.
rewrite Rle_bool_true.
apply refl_equal.
rewrite Rabs_mult.
rewrite (Rabs_pos_eq (bpow (- FLX_exp prec ex))).
change 1%R with (bpow 0).
rewrite <- (Zplus_opp_r (FLX_exp prec ex)).
rewrite bpow_plus.
apply Rmult_le_compat_r.
apply bpow_ge_0.
apply Rle_trans with (2 := proj1 He).
apply bpow_le.
unfold FLX_exp.
generalize (prec_gt_0 prec).
clear -He' ; lia.
apply bpow_ge_0.
unfold FLX_exp, FTZ_exp.
rewrite Zlt_bool_false.
apply refl_equal.
clear -He' ; lia.
Qed.

Theorem round_FTZ_small :
  forall x : R,
  (Rabs x < bpow (emin + prec - 1))%R ->
  round beta FTZ_exp Zrnd_FTZ x = 0%R.
Proof with auto with typeclass_instances.
intros x Hx.
destruct (Req_dec x 0) as [Hx0|Hx0].
rewrite Hx0.
apply round_0...
unfold round, scaled_mantissa, cexp.
destruct (mag beta x) as (ex, He). simpl.
specialize (He Hx0).
unfold Zrnd_FTZ.
rewrite Rle_bool_false.
apply F2R_0.
rewrite Rabs_mult.
rewrite (Rabs_pos_eq (bpow (- FTZ_exp ex))).
change 1%R with (bpow 0).
rewrite <- (Zplus_opp_r (FTZ_exp ex)).
rewrite bpow_plus.
apply Rmult_lt_compat_r.
apply bpow_gt_0.
apply Rlt_le_trans with (1 := Hx).
apply bpow_le.
unfold FTZ_exp.
generalize (Zlt_cases (ex - prec) emin).
case Zlt_bool.
intros _.
apply Z.le_refl.
intros He'.
elim Rlt_not_le with (1 := Hx).
apply Rle_trans with (2 := proj1 He).
apply bpow_le.
lia.
apply bpow_ge_0.
Qed.

End FTZ_round.

End RND_FTZ.


(* action.v

   Copyright (C) 2017, Cong Sun

   This code is a part of CertIA.

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

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

Require Export element.
Require Import MSets.
Require Import String.

(** define an inductive type for the label of action*)
Inductive Act : Type :=
 | act: Element.t -> Act.

Notation "'&' ac" := (act (lbl ac))  (at level 40).

(** define the module of action as a decidable type of action*)
Definition eq_Act (a a':Act):Prop :=
 match a,a' with
 | act e, act e' => Element.eq e e'
 end.

Definition eq_Act_dec : forall a a':Act, {eq_Act a a'}+{~ eq_Act a a'}.
induction a,a'; simpl.
induction t,t0; simpl.
 apply Element.eq_dec.
 right; intro H; inversion H.
 right; intro H; inversion H.
 apply Element.eq_dec.
Defined.

Definition beq_Act (x y:Act) :bool :=
  match x,y with
  | (act sx), (act sy) => Element.beq sx sy
  end.

Module Action <: DecidableType.

Definition t := Act.

Definition eq: t->t->Prop :=eq_Act.

Instance eq_equiv: Equivalence eq.
split.
 unfold Reflexive. induction x; simpl. apply eq_Elt_refl.
 unfold Symmetric. induction x,y; simpl. apply eq_Elt_sym.
 unfold Transitive. induction x,y,z; simpl. apply eq_Elt_trans.
Defined.

Definition eq_dec := eq_Act_dec.

Definition beq := beq_Act.

End Action.

(**define the set of action as a set *)
Module ASet <: WSets.
Include MSetWeakList.Make Action.

(*for the replacement of IA, find any action
both in A and X, and replace these actions in A with a*)
Fixpoint replace_actions_aux (A:list elt) (X:t) (act:Act): t :=
 match A with
 | nil => empty
 | cons a sa =>
   if (mem a X) then (add act (replace_actions_aux sa X act))
   else (add a (replace_actions_aux sa X act))
 end.
Definition replace_actions (A X:t) (act:Act) : t :=
  replace_actions_aux (elements A) X act.

(** lemmas used for the proof of set operations, e.g. shared_composable_eq of IA *)
Lemma inter_a_union_empty:
forall (A B C:t), Equal (inter C (union A B)) empty ->
  (Equal (inter C A) empty /\ Equal (inter C B) empty).
Proof.
 unfold Equal. intros. split.
 induction a; simpl; split.
   destruct (H (act t0)). intros; apply H0.
   rewrite (inter_spec C (union A B)); rewrite (inter_spec C A) in H2. split.
   apply H2. rewrite (union_spec A B). left. apply H2.
   intro H'; inversion H'.
 induction a; simpl; split.
   destruct (H (act t0)); intros.
   apply H0. rewrite (inter_spec C (union A B)); rewrite (inter_spec C B) in H2.
   split; destruct H2. apply H2. rewrite (union_spec A B); right; apply H3.
   intro H'; inversion H'.
Qed.

Lemma inter_union_a_empty:
forall (A B C:t), Equal (inter (union A B) C) empty ->
  Equal (inter A C) empty /\ Equal (inter B C) empty.
Proof.
 unfold Equal; intros; split.
 induction a; simpl; split; intros. destruct (H (act t0)). apply H1.
  rewrite (inter_spec (union A B) C); rewrite (inter_spec A C) in H0. split; destruct H0.
  rewrite (union_spec A B). left; apply H0. apply H3. inversion H0.
 induction a; simpl; split; intros. destruct (H (act t0)). apply H1.
  rewrite (inter_spec (union A B) C); rewrite (inter_spec B C) in H0. split; destruct H0.
  rewrite (union_spec A B). right; apply H0. apply H3. inversion H0.
Qed.

Lemma inter_empty_inv:
  forall (A B:t) (e:elt), Equal (inter A B) empty -> In e A -> In e B ->False.
Proof.
 intros. unfold Equal in H. destruct (H e).
 assert (In e (inter A B)). apply inter_spec. split; auto. apply H2 in H4. inversion H4.
Qed.

(** auxiliary functions for debugging*)
Fixpoint GenActs (acts: list elt): t :=
  match acts with
  | nil => empty
  | cons a acts' => add a (GenActs acts')
  end.

Fixpoint display (l:list elt): string :=
 match l with
 | nil => EmptyString
 | cons a l' => match l' with
    | nil => match a with (act e) => Element.display e end
    | cons _ _ => match a with (act e) =>
         String.append (Element.display e) (append ", " (display l'))
         end
    end
 end.

(*test case
Notation "[ ]" := nil.
Notation "[ x , .. , y ]" := (cons x .. (cons y []) ..).
Eval compute in GenActs [&"msg",&"ack",&"nack"].
Eval compute in display (elements (ASet.GenActs [&"msg",&"ack",&"nack"])).
*)

End ASet.


Require Import Arith.
Require Import EqNat.
Require Import Ring.

(* -------------------------------------------------------------------- *)
From mathcomp Require Import div ssreflect eqtype ssrbool ssrnat seq fintype.
From mathcomp Require Import finset zmodp matrix bigop ssralg matrix ssrnum.
From mathcomp Require Import finmap seq ssrfun finfun matrix ssrnum ssrfun.
From mathcomp Require Import bigop ssralg finset fingroup zmodp poly fingraph.
From mathcomp Require Import tuple choice path perm.
(* -------------------------------------------------------------------- *)
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Open Scope ring_scope.

Import GRing.

Definition p012 : injective [ffun i : 'I_3 => nth i
               [:: @Ordinal 3 0 isT ; @Ordinal 3 1 isT; @Ordinal 3 2 isT] i].
Proof.
by move => [[ | [ | [ | n]]] n3] [[ | [ | [ | m]]] m3];
  rewrite !ffunE //= => h; apply: val_inj.
Qed.

Definition p021 : injective [ffun i : 'I_3 => nth i
              [:: @Ordinal 3 0 isT ; @Ordinal 3 2 isT; @Ordinal 3 1 isT] i].
Proof.
by move => [[ | [ | [ | n]]] n3]
  [[ | [ | [ | m]]] m3];
  rewrite !ffunE //= => h; apply: val_inj.
Qed.

Definition p102 : injective [ffun i : 'I_3 => nth i
              [:: @Ordinal 3 1 isT ; @Ordinal 3 0 isT; @Ordinal 3 2 isT] i].
Proof.
by move => [[ | [ | [ | n]]] n3]
  [[ | [ | [ | m]]] m3];
  rewrite !ffunE //= => h; apply: val_inj.
Qed.

Definition p120 : injective [ffun i : 'I_3 => nth i
              [:: @Ordinal 3 1 isT ; @Ordinal 3 2 isT; @Ordinal 3 0 isT] i].
Proof.
by move => [[ | [ | [ | n]]] n3]
  [[ | [ | [ | m]]] m3];
  rewrite !ffunE //= => h; apply: val_inj.
Qed.

Definition p201 : injective [ffun i : 'I_3 => nth i
              [:: @Ordinal 3 2 isT ; @Ordinal 3 0 isT; @Ordinal 3 1 isT] i].
Proof.
by move => [[ | [ | [ | n]]] n3]
  [[ | [ | [ | m]]] m3];
  rewrite !ffunE //= => h; apply: val_inj.
Qed.

Definition p210 : injective [ffun i : 'I_3 => nth i
              [:: @Ordinal 3 2 isT ; @Ordinal 3 1 isT; @Ordinal 3 0 isT] i].
Proof.
by move => [[ | [ | [ | n]]] n3]
  [[ | [ | [ | m]]] m3];
  rewrite !ffunE //= => h; apply: val_inj.
Qed.

Lemma second_value (s : {perm 'I_3}) (j : 'I_3) :
  val j != s (@Ordinal 3 0 isT) ->
  (s (@Ordinal 3 1 isT) == j) = false ->
  nat_of_ord (s (@Ordinal 3 1 isT)) = (3 - (s (@Ordinal 3 0 isT) + j))%nat.
Proof.
move => js0 hf.
set w1 := (LHS); case h1 : w1 => [ | [ | [ | m]]];
 set w0 := (nat_of_ord _); case h0 : w0 => [ | [ | [ | n]]]; try (
suff : @Ordinal 3 0 isT = @Ordinal 3 1 isT;[ done |
   by apply/(@perm_inj _ s)/val_inj; have : w0 = w1 by rewrite h1]); try (
by have := ltn_ord (s (@Ordinal 3 1 isT)); rewrite [X in (X < 3)%N]h1); try (
by have := ltn_ord (s (@Ordinal 3 0 isT)); rewrite [X in (X < 3)%N]h0);
(case hj : j js0 hf => [[ | [ | [ | nj]]] pj]; [ | | | done]); try (
move => _ /eqP abs; case: abs; apply: val_inj => /=; exact: h1); try (
by move => /eqP abs; case: abs => /=; rewrite -[LHS]h0);
by rewrite /=.
Qed.

Lemma last_value (s : {perm 'I_3}) :
  nat_of_ord (s (@Ordinal 3 2 isT)) =
     (3 - (s (@Ordinal 3 0 isT) + s (@Ordinal 3 1 isT)))%nat.
Proof.
case h0 : (s (@Ordinal 3 0 isT)) => [[ | [ | [ | n]]] p0]; [ | | | done];
(case h1 : (s (@Ordinal 3 1 isT)) => [[ | [ | [ | n1]]] p1]; [ | | | done]); try
(suff : @Ordinal 3 0 isT = @Ordinal 3 1 isT;[done |apply/(@perm_inj _ s);
   rewrite h1 h0; apply val_inj; done ]);
(case h2 : (s (@Ordinal 3 2 isT)) => [[ | [ | [ | n2]]] p2]; [ | | | done]); try
(suff : @Ordinal 3 0 isT = @Ordinal 3 2 isT;[done |apply/(@perm_inj _ s);
   rewrite h2 h0; apply val_inj; done ]); try
(suff : @Ordinal 3 1 isT = @Ordinal 3 2 isT;[done |apply/(@perm_inj _ s);
   rewrite h2 h1; apply val_inj; done ]); by [].
Qed.

Lemma all_perms3 (s : {perm 'I_3}) :
  s \in [:: perm p012 ; perm p021 ; perm p102 ; perm p120 ; perm p201 ; perm p210 ].
Proof.
case h00 : (s (@Ordinal 3 0 isT) == @Ordinal 3 0 isT).
  case h11 : (s (@Ordinal 3 1 isT) == @Ordinal 3 1 isT).
    rewrite in_cons; apply /orP; left.
    apply/eqP/permP; case => [[ | [ | [ | x ]]] x3]; last by [].
        have -> : Ordinal x3 = @Ordinal 3 0 isT  by apply: val_inj.
        by rewrite (eqP h00) /= permE ffunE /=.
      have -> : Ordinal x3 = @Ordinal 3 1 isT  by apply: val_inj.
      by rewrite (eqP h11) /= permE ffunE /=.
   have q2 : Ordinal x3 = @Ordinal 3 2 isT  by apply: val_inj.
   apply/val_inj; rewrite q2 [LHS]last_value.
   by rewrite permE ffunE /= (eqP h00) (eqP h11).
  have h12 : (s (@Ordinal 3 1 isT) == @Ordinal 3 2 isT).
    apply/eqP/val_inj => /=.
    by rewrite (second_value _ h11) // (eqP h00).
  rewrite 2!in_cons; do 1 (apply/orP; right); apply/orP; left.
  apply/eqP/permP; case => [[ | [ | [ | x ]]] x3]; last by [].
      have -> : Ordinal x3 = @Ordinal 3 0 isT  by apply: val_inj.
      by rewrite (eqP h00) /= permE ffunE /=.
    have -> : Ordinal x3 = @Ordinal 3 1 isT  by apply: val_inj.
    by rewrite (eqP h12) /= permE ffunE /=.
  have q2 : Ordinal x3 = @Ordinal 3 2 isT  by apply: val_inj.
  apply/val_inj; rewrite q2 [LHS]last_value.
  by rewrite permE ffunE /= (eqP h00) (eqP h12).
case h01 : (s (@Ordinal 3 0 isT) == @Ordinal 3 1 isT).
  case h10 : (s (@Ordinal 3 1 isT) == @Ordinal 3 0 isT).
  rewrite 3!in_cons; do 2 (apply/orP; right); apply/orP; left.
    apply/eqP/permP; case => [[ | [ | [ | x ]]] x3]; last by [].
        have -> : Ordinal x3 = @Ordinal 3 0 isT  by apply: val_inj.
        by rewrite (eqP h01) /= permE ffunE /=.
      have -> : Ordinal x3 = @Ordinal 3 1 isT  by apply: val_inj.
      by rewrite (eqP h10) /= permE ffunE /=.
   have q2 : Ordinal x3 = @Ordinal 3 2 isT  by apply: val_inj.
   apply/val_inj; rewrite q2 [LHS]last_value.
   by rewrite permE ffunE /= (eqP h01) (eqP h10).
  have h12 : (s (@Ordinal 3 1 isT) == @Ordinal 3 2 isT).
    apply/eqP/val_inj => /=.
    by rewrite (second_value _ h10) // (eqP h01).
  rewrite 4!in_cons; do 3 (apply/orP; right); apply/orP; left.
  apply/eqP/permP; case => [[ | [ | [ | x ]]] x3]; last by [].
      have -> : Ordinal x3 = @Ordinal 3 0 isT  by apply: val_inj.
      by rewrite (eqP h01) /= permE ffunE /=.
    have -> : Ordinal x3 = @Ordinal 3 1 isT  by apply: val_inj.
    by rewrite (eqP h12) /= permE ffunE /=.
  have q2 : Ordinal x3 = @Ordinal 3 2 isT  by apply: val_inj.
  apply/val_inj; rewrite q2 [LHS]last_value.
  by rewrite permE ffunE /= (eqP h01) (eqP h12).
have h02 : s (@Ordinal 3 0 isT) == @Ordinal 3 2 isT.
  by case : (s (@Ordinal 3 0 isT)) h00 h01 => [[ | [ | [ | n]]] pn]
   /eqP h00 /eqP h01;
  try (by case : h00; apply: val_inj); try (by case : h01; apply: val_inj).
case h10 : (s (@Ordinal 3 1 isT) == @Ordinal 3 0 isT).
rewrite 5!in_cons; do 4 (apply/orP; right); apply/orP; left.
  apply/eqP/permP; case => [[ | [ | [ | x ]]] x3]; last by [].
      have -> : Ordinal x3 = @Ordinal 3 0 isT  by apply: val_inj.
      by rewrite (eqP h02) /= permE ffunE /=.
    have -> : Ordinal x3 = @Ordinal 3 1 isT  by apply: val_inj.
    by rewrite (eqP h10) /= permE ffunE /=.
  have q2 : Ordinal x3 = @Ordinal 3 2 isT  by apply: val_inj.
  apply/val_inj; rewrite q2 [LHS]last_value.
  by rewrite permE ffunE /= (eqP h02) (eqP h10).
have h11 : (s (@Ordinal 3 1 isT) == @Ordinal 3 1 isT).
  apply/eqP/val_inj => /=.
  by rewrite (second_value _ h10) // (eqP h02).
rewrite 6!in_cons; do 5 (apply/orP; right); apply/orP; left.
apply/eqP/permP; case => [[ | [ | [ | x ]]] x3]; last by [].
    have -> : Ordinal x3 = @Ordinal 3 0 isT  by apply: val_inj.
    by rewrite (eqP h02) /= permE ffunE /=.
  have -> : Ordinal x3 = @Ordinal 3 1 isT  by apply: val_inj.
  by rewrite (eqP h11) /= permE ffunE /=.
have q2 : Ordinal x3 = @Ordinal 3 2 isT  by apply: val_inj.
apply/val_inj; rewrite q2 [LHS]last_value.
by rewrite permE ffunE /= (eqP h02) (eqP h11).
Qed.

Lemma odd_perm012 : perm p012 = false :> bool.
Proof.
suff -> : perm p012 = 1%g by apply: odd_perm1.
by (apply/permP; case => [ [ | [ | [ | n]]] pn]; [ | | | done]);
  rewrite !permE !ffunE /=; apply val_inj => /=.
Qed.

Lemma odd_perm021 : perm p021 = true :> bool.
Proof.
rewrite [perm _](_ : _ = (tperm (@Ordinal 3 1 isT) (@Ordinal 3 2 isT))); last first.
  (apply/permP; case => [ [ | [ | [ | n]]] pn]; [ | | | done]);
   rewrite !permE !ffunE; apply/val_inj => /=;
   try (rewrite (_ : Ordinal pn = @Ordinal 3 0 isT);[ | by apply: val_inj]);
   try (rewrite (_ : Ordinal pn = @Ordinal 3 1 isT);[ | by apply: val_inj]);
   try (rewrite (_ : Ordinal pn = @Ordinal 3 2 isT);[ | by apply: val_inj]);
   rewrite ?(tpermL, tpermR) //.
by apply: odd_tperm.
Qed.

Lemma odd_perm102 : perm p102 = true :> bool.
Proof.
rewrite [perm _](_ : _ = (tperm (@Ordinal 3 0 isT) (@Ordinal 3 1 isT))); last first.
  (apply/permP; case => [ [ | [ | [ | n]]] pn]; [ | | | done]);
   rewrite !permE !ffunE; apply/val_inj => /=;
   try (rewrite (_ : Ordinal pn = @Ordinal 3 0 isT);[ | by apply: val_inj]);
   try (rewrite (_ : Ordinal pn = @Ordinal 3 1 isT);[ | by apply: val_inj]);
   try (rewrite (_ : Ordinal pn = @Ordinal 3 2 isT);[ | by apply: val_inj]);
   rewrite ?(tpermL, tpermR) //.
by apply: odd_tperm.
Qed.

Lemma odd_perm120 : perm p120 = false :> bool.
Proof.
rewrite [perm _](_ : _ = (tperm (@Ordinal 3 0 isT) (@Ordinal 3 1 isT) *
                       tperm (@Ordinal 3 0 isT) (@Ordinal 3 2 isT))%g); last first.
  (apply/permP; case => [ [ | [ | [ | n]]] pn]; [ | | | done]);
   rewrite !permE !ffunE; apply/val_inj => /=;
   try (rewrite (_ : Ordinal pn = @Ordinal 3 0 isT);[ | by apply: val_inj]);
   try (rewrite (_ : Ordinal pn = @Ordinal 3 1 isT);[ | by apply: val_inj]);
   try (rewrite (_ : Ordinal pn = @Ordinal 3 2 isT);[ | by apply: val_inj]);
   rewrite ?(tpermL, tpermR) //.
   by rewrite tpermD.
  by rewrite [X in (tperm _ _) X]tpermD // tpermR.
by rewrite odd_permM !odd_tperm.
Qed.

Lemma odd_perm210 : perm p210 = true :> bool.
Proof.
rewrite [perm _](_ : _ = (tperm (@Ordinal 3 0 isT) (@Ordinal 3 2 isT))); last first.
  (apply/permP; case => [ [ | [ | [ | n]]] pn]; [ | | | done]);
   rewrite !permE !ffunE; apply/val_inj => /=;
   try (rewrite (_ : Ordinal pn = @Ordinal 3 0 isT);[ | by apply: val_inj]);
   try (rewrite (_ : Ordinal pn = @Ordinal 3 1 isT);[ | by apply: val_inj]);
   try (rewrite (_ : Ordinal pn = @Ordinal 3 2 isT);[ | by apply: val_inj]);
   rewrite ?(tpermL, tpermR) //.
by apply: odd_tperm.
Qed.

Lemma odd_perm201 : perm p201 = false :> bool.
Proof.
rewrite [perm _](_ : _ = (tperm (@Ordinal 3 0 isT) (@Ordinal 3 2 isT) *
                       tperm (@Ordinal 3 0 isT) (@Ordinal 3 1 isT))%g); last first.
  (apply/permP; case => [ [ | [ | [ | n]]] pn]; [ | | | done]);
   rewrite !permE !ffunE; apply/val_inj => /=;
   try (rewrite (_ : Ordinal pn = @Ordinal 3 0 isT);[ | by apply: val_inj]);
   try (rewrite (_ : Ordinal pn = @Ordinal 3 1 isT);[ | by apply: val_inj]);
   try (rewrite (_ : Ordinal pn = @Ordinal 3 2 isT);[ | by apply: val_inj]);
   rewrite ?(tpermL, tpermR) //.
   by rewrite tpermD.
  by rewrite [X in (tperm _ _) X]tpermD // tpermR.
by rewrite odd_permM !odd_tperm.
Qed.

Lemma uniq_size (T: finType) (s t : seq T) :
   uniq s -> {subset s <= t} -> size s = size t -> uniq t.
Proof.
move=> Hu Hs Es; apply/card_uniqP/anti_leq.
rewrite card_size -Es -(_ : #|s| = size s); last by apply: card_uniqP.
apply: subset_leq_card.
by apply/subsetP.
Qed.

Lemma uniq_perms3 :
  uniq [:: perm p012; perm p021; perm p102; perm p120; perm p201; perm p210].
Proof.
have h : uniq (Finite.enum [finType of 'S_3]).
  apply: count_mem_uniq => x; rewrite mem_index_enum; apply/enumP.
apply (uniq_size h).
   by move => /= x _; apply: all_perms3.
rewrite /= -enumT -cardT /=.
have := card_perm (setT : {set 'I_3}).
rewrite cardsT /= card_ord; move => h'; rewrite -[RHS]h'.
apply: eq_card; move => i //=; rewrite inE; symmetry.
by apply/subsetP.
Qed.

Lemma expand_det33 (R : ringType) (M : 'M[R]_(3,3)) : \det M =
  M (@Ordinal 3 0 isT) (@Ordinal 3 0 isT) *
  M (@Ordinal 3 1 isT) (@Ordinal 3 1 isT) *
  M (@Ordinal 3 2 isT) (@Ordinal 3 2 isT) -
  M (@Ordinal 3 0 isT) (@Ordinal 3 0 isT) *
  M (@Ordinal 3 1 isT) (@Ordinal 3 2 isT) *
  M (@Ordinal 3 2 isT) (@Ordinal 3 1 isT) -
  M (@Ordinal 3 0 isT) (@Ordinal 3 1 isT) *
  M (@Ordinal 3 1 isT) (@Ordinal 3 0 isT) *
  M (@Ordinal 3 2 isT) (@Ordinal 3 2 isT) +
  M (@Ordinal 3 0 isT) (@Ordinal 3 1 isT) *
  M (@Ordinal 3 1 isT) (@Ordinal 3 2 isT) *
  M (@Ordinal 3 2 isT) (@Ordinal 3 0 isT) +
  M (@Ordinal 3 0 isT) (@Ordinal 3 2 isT) *
  M (@Ordinal 3 1 isT) (@Ordinal 3 0 isT) *
  M (@Ordinal 3 2 isT) (@Ordinal 3 1 isT) -
  M (@Ordinal 3 0 isT) (@Ordinal 3 2 isT) *
  M (@Ordinal 3 1 isT) (@Ordinal 3 1 isT) *
  M (@Ordinal 3 2 isT) (@Ordinal 3 0 isT).
Proof.
rewrite /determinant.
rewrite (eq_big_perm  [:: perm p012 ; perm p021 ; perm p102 ; perm p120 ;
                          perm p201 ; perm p210 ]).
  rewrite !big_cons big_nil/= addr0 !addrA odd_perm012 odd_perm021 odd_perm102
           odd_perm120 odd_perm210 odd_perm201.
  rewrite !big_ord_recl /= !big_ord0 expr0 expr1 !mulNr !mul1r !mulr1 !mulrA.
  rewrite (_ : ord0 = @Ordinal 3 0 isT); last by apply: val_inj.
  set w := (lift _ (ord0 : 'I_3.-1)).
  have -> : w = @Ordinal 3 1 isT by apply: val_inj.
  set w2 := (lift _ (lift _ _)).
  have -> : w2 = @Ordinal 3 2 isT by apply: val_inj.
  by rewrite !permE !ffunE.
apply uniq_perm_eq.
    by apply: count_mem_uniq => x; rewrite mem_index_enum; apply/enumP.
  by apply: uniq_perms3.
by  move => s; rewrite mem_index_enum all_perms3.
Qed.


(****************************************************************
   File: Shapes.v
   Author: Amy Felty

   original: January 2010
   updated: March 2014
   Mar 2021: Current Coq Version: V8.13.1

   Definition of lambda terms, predicates, and judgments plus
   proofs of internal adequacy for all judgments

  ***************************************************************)

From HybridSys Require Export sl.

#[global] Hint Resolve level_CON level_VAR level_BND level_APP level_ABS : hybrid.
#[global] Hint Resolve proper_APP abstr_proper : hybrid.
#[global] Hint Unfold proper: hybrid.

Section encoding.

Hint Rewrite ext_eq_eta : hybrid.

(****************************************************************
   Constants for Two Kinds of Terms
  ****************************************************************)

Inductive Econ: Set := cAPP: Econ | cLAM: Econ | cAPPLY : Econ | cFUN : Econ.
Definition uexp : Set := expr Econ.

Definition Var : var -> uexp := (VAR Econ).
Definition Bnd : bnd -> uexp := (BND Econ).
Definition app : uexp -> uexp -> uexp :=
  fun e1:uexp => fun e2:uexp => (APP (APP (CON cAPP) e1) e2).
Definition lam : (uexp -> uexp) -> uexp :=
  fun e:uexp->uexp => (APP (CON cLAM) (lambda e)).
Definition apply : uexp -> uexp -> uexp :=
  fun e1:uexp => fun e2:uexp => (APP (APP (CON cAPPLY) e1) e2).
Definition fn : (uexp -> uexp) -> uexp :=
  fun e:uexp->uexp => (APP (CON cFUN) (lambda e)).

(****************************************************************
   Some Properties of Constructors
  ****************************************************************)

Lemma proper_Var: forall x:var, (proper (Var x)).
Proof.
unfold Var; auto with hybrid.
Qed.

Lemma proper_lam : forall (e:uexp->uexp),
  abstr e -> proper (lam e).
Proof.
unfold lam; auto with hybrid.
Qed.

Lemma proper_app : forall e1 e2:uexp,
  proper e1 -> proper e2 -> proper (app e1 e2).
Proof.
unfold app; auto with hybrid.
Qed.

Lemma proper_fn : forall (e:uexp->uexp),
  abstr e -> proper (fn e).
Proof.
unfold fn; auto with hybrid.
Qed.

Lemma proper_apply : forall e1 e2:uexp,
  proper e1 -> proper e2 -> proper (apply e1 e2).
Proof.
unfold apply; auto with hybrid.
Qed.

Hint Resolve proper_Var : hybrid.

(****************************************************************
   The atm type and instantiation of oo.
  ****************************************************************)

Inductive atm : Set :=
   is_tm : uexp -> atm
 | is_exp : uexp -> atm
 | eq_a : uexp -> uexp -> atm
 | shape : uexp -> uexp -> atm
 | varT : uexp -> atm
 | varE : uexp -> atm
 | varTOcc : uexp -> nat -> atm
 | varEOcc : uexp -> nat -> atm.

Definition oo_ := oo atm Econ.
Definition atom_ : atm -> oo_ := atom Econ.
Definition T_ : oo_ := T atm Econ.

Hint Unfold oo_ atom_ T_: hybrid.
Hint Unfold oo_ atom_ T_: hybrid.

(****************************************************************
   Definition of prog
  ****************************************************************)

Inductive prog : atm -> oo_ -> Prop :=
  (* well-formedness of terms (app and lam) *)
  | tm_app : forall T1 T2:uexp,
      prog (is_tm (app T1 T2))
        (Conj (atom_ (is_tm T1)) (atom_ (is_tm T2)))
  | tm_lam : forall T:uexp->uexp, abstr T ->
      prog (is_tm (lam T))
        (All (fun x:uexp =>
          (Imp (is_tm x) (atom_ (is_tm (T x))))))
  (* well-formedness of expressions (apply and fn) *)
  | exp_apply : forall E1 E2:uexp,
      prog (is_exp (apply E1 E2))
        (Conj (atom_ (is_exp E1)) (atom_ (is_exp E2)))
  | exp_fn : forall E:uexp->uexp, abstr E ->
      prog (is_exp (fn E))
        (All (fun x:uexp =>
          (Imp (is_exp x) (atom_ (is_exp (E x))))))
  (* algorithmic equality between terms and expressions *)
  | eq_lam : forall T E:uexp->uexp, abstr T -> abstr E ->
      prog (eq_a (lam T) (fn E))
        (All (fun x:uexp =>
          (All (fun y:uexp =>
            (Imp (eq_a x y) (atom_ (eq_a (T x) (E y))))))))
  | eq_app : forall T1 T2 E1 E2:uexp,
      prog (eq_a (app T1 T2) (apply E1 E2))
        (Conj (atom_ (eq_a T1 E1)) (atom_ (eq_a T2 E2)))
  (* same shape for terms and expressions *)
  | sh_v : forall T E:uexp,
      prog (shape T E)
      (Conj (atom_ (varT T)) (atom_ (varE E)))
  | sh_lam : forall T E:uexp->uexp, abstr T -> abstr E ->
      prog (shape (lam T) (fn E))
        (All (fun x:uexp =>
          (All (fun y:uexp =>
            (Imp (varT x) (Imp (varE y) (atom_ (shape (T x) (E y)))))))))
  | sh_app : forall T1 T2 E1 E2:uexp,
      prog (shape (app T1 T2) (apply E1 E2))
        (Conj (atom_ (shape T1 E1)) (atom_ (shape T2 E2)))
  (* counting variables in terms *)
  | v_lm : forall T:uexp->uexp, forall N:nat, abstr T ->
      prog (varTOcc (lam T) N)
        (All (fun x:uexp => (Imp (varT x) (atom_ (varTOcc (T x) N)))))
  | v_app : forall T1 T2:uexp, forall N1 N2:nat,
      prog (varTOcc (app T1 T2) (N1+N2))
        (Conj (atom_ (varTOcc T1 N1)) (atom_ (varTOcc T2 N2)))
  | v_varT : forall T:uexp,
      prog (varTOcc T 1) (atom_ (varT T))
  (* counting variables in expressions *)
  | v_fn : forall E:uexp->uexp, forall N:nat, abstr E ->
      prog (varEOcc (fn E) N)
        (All (fun x:uexp => (Imp (varE x) (atom_ (varEOcc (E x) N)))))
  | v_apply : forall E1 E2:uexp, forall N1 N2:nat,
      prog (varEOcc (apply E1 E2) (N1+N2))
        (Conj (atom_ (varEOcc E1 N1)) (atom_ (varEOcc E2 N2)))
  | v_varE : forall E:uexp,
      prog (varEOcc E 1) (atom_ (varE E)).

(****************************************************************
   Instantiation of seq
  ****************************************************************)

Definition seq_ : nat -> list atm -> oo_ -> Prop := sl.seq prog.
Definition seq'_ := seq' prog.
Definition seq0 (B : oo_) : Prop := seq'_ nil B.

End encoding.

#[global] Hint Unfold oo_ atom_ T_: hybrid.
#[global] Hint Unfold seq_ seq'_ seq0: hybrid.
#[global] Hint Unfold proper: hybrid.
#[global] Hint Resolve proper_Var : hybrid.
#[global] Hint Resolve tm_app tm_lam exp_apply exp_fn
               eq_lam eq_app sh_v sh_lam sh_app
               v_lm v_app v_varT v_fn v_apply v_varE : hybrid.
#[global] Hint Unfold seq_ seq'_ seq0: hybrid.
#[global] Hint Resolve proper_Var : hybrid.

(****************************************************************
   Specialized Inversion Properties of prog
  ****************************************************************)

Section prog_inv.

Hint Rewrite ext_eq_eta : hybrid.

Lemma eq_lam_inv :
forall (i:nat) (Psi:list atm) (T E:uexp->uexp),
seq_ i Psi (All (fun x:uexp => All (fun y:uexp =>
                Imp (eq_a x y) (atom_ (eq_a (T x) (E y)))))) ->
exists j:nat, (i=j+3 /\
 forall (x y:uexp),
       proper x -> proper y ->
       seq_ j (eq_a x y::Psi) (atom_ (eq_a (T x) (E y)))).
Proof.
intro i; case i.
- intros Psi T E H.
  inversion H; clear H; subst.
  replace (i0+1) with (S i0) in H0; try lia.
- clear i; intro i; case i.
  + intros Psi T E H.
    inversion H; clear H; subst.
    generalize (H3 (Var 0) (proper_Var 0)); intro H1.
    inversion H1; clear H1; subst.
    replace (i1+1+1) with (S (S i1)) in H0; try lia.
  + clear i; intro i; case i.
    * intros Psi T E H.
      inversion H; clear H; subst.
      generalize (H3 (Var 0) (proper_Var 0)); clear H3; intro H1.
      inversion H1; clear H1; subst.
      generalize (H4 (Var 0) (proper_Var 0)); clear H4; intro H1.
      inversion H1; clear H1; subst.
      replace (i0+1+1+1) with (S (S (S i0))) in H0; try lia.
    * intros n Psi T E h.
      exists n; split; try lia.
      intros x y H0 H1.
      inversion h; clear h; subst.
      generalize (H4 x H0); clear H4; intro H4.
      inversion H4; clear H4; subst.
      generalize (H6 y H1); clear H6; intro H6.
      inversion H6; clear H6; subst.
      assert (i0 = n); try lia.
      subst; auto.
Qed.

Lemma shape_lam_inv :
forall (i:nat) (Psi:list atm) (T E:uexp->uexp),
seq_ i Psi (All (fun x:uexp => All (fun y:uexp =>
           Imp (varT x) (Imp (varE y) (atom_ (shape (T x) (E y))))))) ->
exists j:nat, (i=j+4 /\
 forall (x y:uexp),
       proper x -> proper y ->
       seq_ j (varE y::varT x::Psi) (atom_ (shape (T x) (E y)))).
Proof.
intro i; case i.
- intros Psi T E H.
  inversion H; clear H; subst.
  replace (i0+1) with (S i0) in H0; try lia.
- clear i; intro i; case i.
  + intros Psi T E H.
    inversion H; clear H; subst.
    generalize (H3 (Var 0) (proper_Var 0)); intro H1.
    inversion H1; clear H1; subst.
    replace (i1+1+1) with (S (S i1)) in H0; try lia.
  + clear i; intro i; case i.
    * intros Psi T E H.
      inversion H; clear H; subst.
      generalize (H3 (Var 0) (proper_Var 0)); clear H3; intro H1.
      inversion H1; clear H1; subst.
      generalize (H4 (Var 0) (proper_Var 0)); clear H4; intro H1.
      inversion H1; clear H1; subst.
      replace (i0+1+1+1) with (S (S (S i0))) in H0; try lia.
    * clear i; intro i; case i.
      -- intros Psi T E H.
         inversion H; clear H; subst.
         generalize (H3 (Var 0) (proper_Var 0)); clear H3; intro H1.
         inversion H1; clear H1; subst.
         generalize (H4 (Var 0) (proper_Var 0)); clear H4; intro H1.
         inversion H1; clear H1; subst.
         inversion H4; clear H4; subst.
         replace (i1+1+1+1+1) with (S (S (S (S i1)))) in H0; try lia.
      -- intros n Psi T E h.
         exists n; split; try lia.
         intros x y H0 H1.
         inversion h; clear h; subst.
         generalize (H4 x H0); clear H4; intro H4.
         inversion H4; clear H4; subst.
         generalize (H6 y H1); clear H6; intro H6.
         inversion H6; clear H6; subst.
         inversion H5; clear H5; subst.
         assert (i1 = n); try lia.
         subst; auto.
Qed.

Lemma varTOcc_lam_inv :
forall (i N:nat) (Psi:list atm) (T:uexp->uexp),
seq_ i Psi (All (fun x:uexp => Imp (varT x) (atom_ (varTOcc (T x) N)))) ->
exists j:nat, (i=j+2 /\
 forall (x:uexp), proper x ->
       seq_ j (varT x::Psi) (atom_ (varTOcc (T x) N))).
Proof.
intro i; case i.
- intros N Psi T H.
  inversion H; clear H; subst.
  replace (i0+1) with (S i0) in H0; try lia.
- clear i; intro i; case i.
  + intros N Psi T H.
    inversion H; clear H; subst.
    generalize (H3 (Var 0) (proper_Var 0)); intro H1.
    inversion H1; clear H1; subst.
    replace (i1+1+1) with (S (S i1)) in H0; try lia.
  + intros n N Psi T h.
    exists n; split; try lia.
    intros x H0.
    inversion h; clear h; subst.
    generalize (H3 x H0); clear H3; intro H4.
    inversion H4; clear H4; subst.
    assert (i1 = n); try lia.
    subst; auto.
Qed.

End prog_inv.

(****************************************************************
   Adequacy
  ****************************************************************)

Section proper_adeq.

Hint Rewrite ext_eq_eta : hybrid.

Lemma is_tm_proper : forall T:uexp,
  seq0 (atom_ (is_tm T)) -> (proper T).
Proof.
intros T [n h1].
generalize T h1; clear h1 T.
generalize
 (lt_wf_ind n
    (fun n:nat =>
       forall T : uexp, seq_ n nil (atom_ (is_tm T)) -> proper T)).
intro h'.
apply h'; clear h'; auto.
clear n.
intros n h1 T h2.
inversion h2; clear h2; subst.
inversion H0; clear H0; subst.
(* app case *)
- inversion H3; clear H3; subst.
  apply proper_app; auto.
  + apply h1 with i0; auto; try lia.
  + apply h1 with i0; auto; try lia.
(* lam case *)
- inversion H3; clear H3; subst.
  apply proper_lam; auto.
Qed.

Lemma is_exp_proper : forall E:uexp,
  seq0 (atom_ (is_exp E)) -> (proper E).
Proof.
intros E [n h1].
generalize E h1; clear h1 E.
generalize
 (lt_wf_ind n
    (fun n:nat =>
       forall E : uexp, seq_ n nil (atom_ (is_exp E)) -> proper E)).
intro h'.
apply h'; clear h'; auto.
clear n.
intros n h1 E h2.
inversion h2; clear h2; subst.
inversion H0; clear H0; subst.
(* apply case *)
- inversion H3; clear H3; subst.
  apply proper_apply; auto.
  apply h1 with i0; auto; try lia.
  apply h1 with i0; auto; try lia.
(* fn case *)
- inversion H3; clear H3; subst.
  apply proper_fn; auto.
Qed.

Lemma eq_proper : forall T E:uexp,
  seq0 (atom_ (eq_a T E)) -> (proper T /\ proper E).
Proof.
intros T E [n h1].
generalize T E h1; clear h1 T E.
generalize
 (lt_wf_ind n
    (fun n:nat =>
       forall T E : uexp, seq_ n nil (atom_ (eq_a T E)) ->
        (proper T /\ proper E))).
intro h'.
apply h'; clear h'; auto.
clear n.
intros n h1 T E h2.
inversion h2; clear h2; subst.
inversion H0; clear H0; subst.
(* fn case *)
- split.
  + apply proper_lam; auto.
  + apply proper_fn; auto.
(* apply case *)
- inversion H3; clear H3; subst.
  generalize h1; generalize h1; intros h2 h3.
  assert (h4:i0<i0+1+1); try lia.
  specialize h2 with (1:=h4) (2:=H4); elim h2; clear h2; intros h2 h5.
  specialize h3 with (1:=h4) (2:=H5); elim h3; clear h3; intros h3 h6.
  split.
  + apply proper_app; auto.
  + apply proper_apply; auto.
Qed.

Lemma shape_proper : forall T E:uexp,
  seq0 (atom_ (shape T E)) -> (proper T /\ proper E).
Proof.
intros T E [n h1].
generalize T E h1; clear h1 T E.
generalize
 (lt_wf_ind n
    (fun n:nat =>
       forall T E : uexp, seq_ n nil (atom_ (shape T E)) ->
        (proper T /\ proper E))).
intro h'.
apply h'; clear h'; auto.
clear n.
intros n h1 T E h2.
inversion h2; clear h2; subst.
inversion H0; clear H0; subst.
(* var case *)
- inversion H3; subst; clear H3.
  inversion H4; subst; clear H4.
  inversion H0; subst; clear H0.
(* fn case *)
- split.
  + apply proper_lam; auto.
  + apply proper_fn; auto.
(* apply case *)
- inversion H3; clear H3; subst.
  generalize h1; generalize h1; intros h2 h3.
  assert (h4:i0<i0+1+1); try lia.
  specialize h2 with (1:=h4) (2:=H4); elim h2; clear h2; intros h2 h5.
  specialize h3 with (1:=h4) (2:=H5); elim h3; clear h3; intros h3 h6.
  split.
  + apply proper_app; auto.
  + apply proper_apply; auto.
Qed.

Lemma varTOcc_proper : forall T:uexp, forall n:nat,
  seq0 (atom_ (varTOcc T n)) -> proper T.
Proof.
intros T n [i h1].
generalize T n h1; clear h1 T n.
generalize
 (lt_wf_ind i
    (fun i:nat =>
       forall T:uexp, forall n:nat, seq_ i nil (atom_ (varTOcc T n)) ->
        proper T)).
intro h'.
apply h'; clear h'; auto.
clear i.
intros i h1 T n h2.
inversion h2; clear h2; subst.
inversion H0; clear H0; subst.
(* lam case *)
- apply proper_lam; auto.
(* apply case *)
- inversion H3; clear H3; subst.
  generalize h1; generalize h1; intros h2 h3.
  assert (h4:i<i+1+1); try lia.
  specialize h2 with (1:=h4) (2:=H4).
  specialize h3 with (1:=h4) (2:=H5).
  apply proper_app; auto.
(* var case *)
- inversion H3; clear H3; subst.
  inversion H0; clear H0; subst.
Qed.

Lemma varEOcc_proper : forall E:uexp, forall n:nat,
  seq0 (atom_ (varEOcc E n)) -> proper E.
Proof.
intros E n [i h1].
generalize E n h1; clear h1 E n.
generalize
 (lt_wf_ind i
    (fun i:nat =>
       forall E:uexp, forall n:nat, seq_ i nil (atom_ (varEOcc E n)) ->
        proper E)).
intro h'.
apply h'; clear h'; auto.
clear i.
intros i h1 E n h2.
inversion h2; clear h2; subst.
inversion H0; clear H0; subst.
(* lam case *)
- apply proper_fn; auto.
(* apply case *)
- inversion H3; clear H3; subst.
  generalize h1; generalize h1; intros h2 h3.
  assert (h4:i<i+1+1); try lia.
  specialize h2 with (1:=h4) (2:=H4).
  specialize h3 with (1:=h4) (2:=H5).
  apply proper_apply; auto.
(* var case *)
- inversion H3; clear H3; subst.
  inversion H0; clear H0; subst.
Qed.

End proper_adeq.

Section eq_adeq.

Hint Rewrite ext_eq_eta : hybrid.

Inductive ateR: list atm -> list atm -> list atm -> Prop :=
| nil_ate: ateR nil nil nil
| cons_ate: forall (Phi Psi Psi':list atm) (x y:uexp), proper x -> proper y ->
    ateR Phi Psi Psi' ->
    ateR (eq_a x y::Phi) (is_tm x::Psi) (is_exp y::Psi').

Hint Resolve nil_ate cons_ate : hybrid.

Lemma memb_ate : forall (Phi Psi Psi':list atm) (x y:uexp),
  ateR Phi Psi Psi' -> In (eq_a x y) Phi ->
  (In (is_tm x) Psi /\ In (is_exp y) Psi').
Proof.
intros Phi Psi Psi' x y; induction 1; eauto with hybrid.
intro h2; simpl in h2; destruct h2 as [h2 | h2].
- injection h2; intros; subst; simpl; auto.
- simpl; tauto.
Qed.

Lemma eq_adeq :
  forall (i:nat) (T E:uexp) (Phi Psi Psi':list atm),
  ateR Phi Psi Psi' ->
  seq_ i Phi (atom_ (eq_a T E)) ->
  seq_ i Psi (atom_ (is_tm T)) /\ seq_ i Psi' (atom_ (is_exp E)).
Proof.
intro i.
generalize
 (lt_wf_ind i
    (fun i:nat =>
     forall (T E:uexp) (Phi Psi Psi':list atm),
     ateR Phi Psi Psi' ->
     seq_ i Phi (atom_ (eq_a T E)) ->
     seq_ i Psi (atom_ (is_tm T)) /\ seq_ i Psi' (atom_ (is_exp E)))).
intro H'.
apply H'; clear H' i; auto.
intros i h T E Phi Psi Psi' cInv h1.
inversion h1; subst; clear h1.
- inversion H0; subst; clear H0.
  (* lam case *)
  + generalize (eq_lam_inv i0 Phi T0 E0 H3); clear H3; intros [j [h1 h2]];
      subst.
    assert (h':forall (x y:uexp), proper x -> proper y ->
        (seq_ j (is_tm x:: Psi) (atom_ (is_tm (T0 x))) /\
         seq_ j (is_exp y:: Psi') (atom_ (is_exp (E0 y))))).
    { intros x y h1 h3.
      apply h with (eq_a x y::Phi); auto; try lia; eauto with hybrid. }
    replace (j+3) with (j+1+1+1); try lia.
    split.
    * unfold seq_,atom_;
        apply s_bc with (All (fun x:uexp => (Imp (is_tm x) (atom_ (is_tm (T0 x))))));
        auto with hybrid.
      apply s_all; auto.
      intros x h5.
      apply s_imp; auto.
      apply seq_mono with j; try lia.
      generalize (h' x (Var 0) h5 (proper_Var 0)); tauto.
    * unfold seq_,atom_;
        apply s_bc with
            (All (fun x:uexp => (Imp (is_exp x) (atom_ (is_exp (E0 x))))));
        auto with hybrid.
      apply s_all; auto.
      intros x h5.
      apply s_imp; auto.
      apply seq_mono with j; try lia.
      generalize (h' (Var 0) x (proper_Var 0) h5); tauto.
  (* app case *)
  + inversion H3; subst; clear H3.
    assert (hi:i<i+1+1); try lia.
    generalize h; intro h'.
    specialize h with (1:=hi) (2:=cInv) (3:=H4).
    specialize h' with (1:=hi) (2:=cInv) (3:=H5).
    elim h; intros h2 h3; elim h'; intros h4 h5; clear h h'.
    split.
    * unfold seq_,atom_;
        apply s_bc with (Conj (atom_ (is_tm T1)) (atom_ (is_tm T2)));
        auto with hybrid.
      apply s_and; auto.
    * unfold seq_,atom_;
        apply s_bc with (Conj (atom_ (is_exp E1)) (atom_ (is_exp E2)));
        auto with hybrid.
      apply s_and; auto.
(* context case *)
- specialize memb_ate with (1:=cInv) (2:=H2); intros [h1 h2]; clear H2.
  split.
  + inversion cInv; subst.
    apply s_init; auto with hybrid.
  + inversion cInv; subst.
    apply s_init; auto with hybrid.
Qed.

Lemma eq_adeq_cor : forall T E:uexp, seq0 (atom_ (eq_a T E)) ->
  (seq0 (atom_ (is_tm T)) /\ seq0 (atom_ (is_exp E))).
Proof.
intros T E [i h1].
generalize nil_ate; intro h2.
specialize eq_adeq with (1:=h2) (2:=h1); intro h.
split; exists i; tauto.
Qed.

End eq_adeq.

Section shape_adeq.

Hint Rewrite ext_eq_eta : hybrid.

Inductive steR: list atm -> list atm -> list atm -> Prop :=
| nil_ste: steR nil nil nil
| cons_ste: forall (Phi Psi Psi':list atm) (x y:uexp), proper x -> proper y ->
    steR Phi Psi Psi' ->
    steR (varE y::varT x::Phi) (is_tm x::Psi) (is_exp y::Psi').

Hint Resolve nil_ste cons_ste : hybrid.

Lemma memb_ste1: forall (Phi Psi Psi':list atm) (x y:uexp),
  steR Phi Psi Psi' -> ~(In (shape x y) Phi).
Proof.
intros Phi Psi Psi' x y; induction 1; eauto with hybrid.
simpl; intros [h1 | [h1 | h1]]; try discriminate h1; try tauto.
Qed.

Lemma memb_ste2 : forall (Phi Psi Psi':list atm) (x:uexp),
  steR Phi Psi Psi' -> In (varT x) Phi -> In (is_tm x) Psi.
Proof.
intros Phi Psi Psi' x; induction 1; eauto with hybrid.
intro h2; simpl in h2; destruct h2 as [h2 | [h2 | h2]].
- discriminate h2.
- injection h2; intros; subst; simpl; auto.
- simpl; tauto.
Qed.

Lemma memb_ste3 : forall (Phi Psi Psi':list atm) (x:uexp),
  steR Phi Psi Psi' -> In (varE x) Phi -> In (is_exp x) Psi'.
Proof.
intros Phi Psi Psi' x; induction 1; eauto with hybrid.
intro h2; simpl in h2; destruct h2 as [h2 | [h2 | h2]].
- injection h2; intros; subst; simpl; auto.
- discriminate h2.
- simpl; tauto.
Qed.

Lemma shape_adeq :
  forall (i:nat) (T E:uexp) (Phi Psi Psi':list atm),
  steR Phi Psi Psi' ->
  seq_ i Phi (atom_ (shape T E)) ->
  seq_ i Psi (atom_ (is_tm T)) /\ seq_ i Psi' (atom_ (is_exp E)).
Proof.
intro i.
generalize
 (lt_wf_ind i
    (fun i:nat =>
     forall (T E:uexp) (Phi Psi Psi':list atm),
     steR Phi Psi Psi' ->
     seq_ i Phi (atom_ (shape T E)) ->
     seq_ i Psi (atom_ (is_tm T)) /\ seq_ i Psi' (atom_ (is_exp E)))).
intro H'.
apply H'; clear H' i; auto.
intros i h T E Phi Psi Psi' cInv h1.
inversion h1; subst; clear h1.
- inversion H0; subst; clear H0.
  (* var case *)
  + inversion H3; subst; clear H3.
    inversion H4; subst; clear H4.
    * inversion H0; subst; clear H0.
    * specialize memb_ste2 with (1:=cInv) (2:=H2); case Psi.
      -- simpl; tauto.
      -- intros a Phi h1.
         split.
         ++ apply s_init; auto with hybrid.
         ++ inversion H5; subst; clear H5.
            ** inversion H0; subst; clear H0.
            ** specialize memb_ste3 with (1:=cInv) (2:=H1); case Psi'.
               --- simpl; tauto.
               --- intros a' Phi' h1'.
                   apply s_init; auto with hybrid.
  (* lam case *)
  + generalize (shape_lam_inv i0 Phi T0 E0 H3); clear H3; intros [j [h1 h2]];
      subst.
    assert (h':forall (x y:uexp), proper x -> proper y ->
        (seq_ j (is_tm x:: Psi) (atom_ (is_tm (T0 x))) /\
         seq_ j (is_exp y:: Psi') (atom_ (is_exp (E0 y))))).
    { intros x y h1 h3.
      apply h with (varE y::varT x::Phi); eauto with hybrid; try lia. }
    replace (j+4+1) with (j+1+1+1+1+1); try lia.
    split.
    * unfold seq_,atom_;
        apply s_bc with (All (fun x:uexp => (Imp (is_tm x) (atom_ (is_tm (T0 x))))));
        auto with hybrid.
      apply s_all; auto.
      intros x h5.
      apply s_imp; auto.
      apply seq_mono with j; try lia.
      generalize (h' x (Var 0) h5 (proper_Var 0)); tauto.
    * unfold seq_,atom_;
        apply s_bc with (All (fun x:uexp => (Imp (is_exp x) (atom_ (is_exp (E0 x))))));
        auto with hybrid.
      apply s_all; auto.
      intros x h5.
      apply s_imp; auto.
      apply seq_mono with j; try lia.
      generalize (h' (Var 0) x (proper_Var 0) h5); tauto.
  (* app case *)
  + inversion H3; subst; clear H3.
    assert (hi:i<i+1+1); try lia.
    generalize h; intro h'.
    specialize h with (1:=hi) (2:=cInv) (3:=H4).
    specialize h' with (1:=hi) (2:=cInv) (3:=H5).
    elim h; intros h2 h3; elim h'; intros h4 h5; clear h h'.
    split.
    * unfold seq_,atom_;
        apply s_bc with (Conj (atom_ (is_tm T1)) (atom_ (is_tm T2)));
        auto with hybrid.
      apply s_and; auto.
    * unfold seq_,atom_;
        apply s_bc with (Conj (atom_ (is_exp E1)) (atom_ (is_exp E2)));
        auto with hybrid.
      apply s_and; auto.
(* context case *)
- specialize memb_ste1 with (x:=T) (y:=E) (1:=cInv); intro; tauto.
Qed.

Lemma shape_adeq_cor : forall T E:uexp, seq0 (atom_ (shape T E)) ->
  (seq0 (atom_ (is_tm T)) /\ seq0 (atom_ (is_exp E))).
Proof.
intros T E [n h1].
generalize nil_ste; intro h2.
specialize shape_adeq with (1:=h2) (2:=h1); intro h.
split; exists n; tauto.
Qed.

End shape_adeq.

Section varTOcc_adeq.

Hint Rewrite ext_eq_eta : hybrid.

Inductive vtR: list atm -> list atm -> Prop :=
| nil_vt: vtR nil nil
| cons_vt: forall (Phi Psi:list atm) (x:uexp), proper x ->
    vtR Phi Psi -> vtR (varT x::Phi) (is_tm x::Psi).

Hint Resolve nil_vt cons_vt : hybrid.

Lemma memb_vt1: forall (Phi Psi:list atm) (x:uexp) (n:nat),
  vtR Phi Psi -> ~(In (varTOcc x n) Phi).
Proof.
intros Phi Psi x n; induction 1; eauto with hybrid.
simpl; intros [h1 | h1]; try discriminate h1; try tauto.
Qed.

Lemma memb_vt2 : forall (Phi Psi:list atm) (x:uexp),
  vtR Phi Psi -> In (varT x) Phi -> In (is_tm x) Psi.
Proof.
intros Phi Psi x; induction 1; eauto with hybrid.
intro h2; simpl in h2; destruct h2 as [h2 | h2].
- injection h2; intros; subst; simpl; auto.
- simpl; tauto.
Qed.

Lemma varTOcc_adeq :
  forall (i n:nat) (T:uexp) (Phi Psi:list atm),
  vtR Phi Psi ->
  seq_ i Phi (atom_ (varTOcc T n)) -> seq_ i Psi (atom_ (is_tm T)).
Proof.
intro i.
generalize
 (lt_wf_ind i
    (fun i:nat =>
     forall (n:nat) (T:uexp) (Phi Psi:list atm),
     vtR Phi Psi ->
     seq_ i Phi (atom_ (varTOcc T n)) -> seq_ i Psi (atom_ (is_tm T)))).
intro H'.
apply H'; clear H' i; auto.
intros i h n T Phi Psi cInv h1.
inversion h1; subst; clear h1.
- inversion H0; subst; clear H0.
  (* lam case *)
  + inversion H3; subst; clear H3.
    unfold seq_,atom_;
      apply s_bc with (All (fun x:uexp => (Imp (is_tm x) (atom_ (is_tm (T0 x))))));
      auto with hybrid.
    apply s_all; auto.
    intros x h5.
    specialize (H2 x h5).
    inversion H2; subst; clear H2.
    apply s_imp; auto.
    apply h with n (varT x::Phi); eauto with hybrid; try lia.
  (* app case *)
  + inversion H3; subst; clear H3.
    unfold seq_,atom_;
      apply s_bc with (Conj (atom_ (is_tm T1)) (atom_ (is_tm T2)));
      auto with hybrid.
    apply s_and; auto.
    * apply h with N1 Phi; auto; try lia.
    * apply h with N2 Phi; auto; try lia.
  (* var case *)
  + inversion H3; subst; clear H3.
    inversion H0; subst; clear H0.
    specialize memb_vt2 with (1:=cInv) (2:=H2); case Psi.
    * simpl; tauto.
    * intros a Phi h1.
      apply s_init; auto with hybrid.
(* context case *)
- specialize memb_vt1 with (x:=T) (n:=n) (1:=cInv); intro; tauto.
Qed.

Lemma varTOcc_adeq_cor : forall (T:uexp) (n:nat),
  seq0 (atom_ (varTOcc T n)) -> seq0 (atom_ (is_tm T)).
Proof.
intros T n [i h].
generalize nil_vt; intro h2.
specialize varTOcc_adeq with (1:=h2) (2:=h); intro; exists i; auto.
Qed.

End varTOcc_adeq.

Section varEOcc_adeq.

Hint Rewrite ext_eq_eta : hybrid.

Inductive veR: list atm -> list atm -> Prop :=
| nil_ve: veR nil nil
| cons_ve: forall (Phi Psi:list atm) (x:uexp), proper x ->
    veR Phi Psi -> veR (varE x::Phi) (is_exp x::Psi).

Hint Resolve nil_ve cons_ve : hybrid.

Lemma memb_ve1: forall (Phi Psi:list atm) (x:uexp) (n:nat),
  veR Phi Psi -> ~(In (varEOcc x n) Phi).
Proof.
intros Phi Psi x n; induction 1; eauto with hybrid.
simpl; intros [h1 | h1]; try discriminate h1; try tauto.
Qed.

Lemma memb_ve2 : forall (Phi Psi:list atm) (x:uexp),
  veR Phi Psi -> In (varE x) Phi -> In (is_exp x) Psi.
Proof.
intros Phi Psi x; induction 1; eauto with hybrid.
intro h2; simpl in h2; destruct h2 as [h2 | h2].
injection h2; intros; subst; simpl; auto.
simpl; tauto.
Qed.

Lemma varEOcc_adeq :
  forall (i n:nat) (E:uexp) (Phi Psi:list atm),
  veR Phi Psi ->
  seq_ i Phi (atom_ (varEOcc E n)) -> seq_ i Psi (atom_ (is_exp E)).
Proof.
intro i.
generalize
 (lt_wf_ind i
    (fun i:nat =>
     forall (n:nat) (E:uexp) (Phi Psi:list atm),
     veR Phi Psi ->
     seq_ i Phi (atom_ (varEOcc E n)) -> seq_ i Psi (atom_ (is_exp E)))).
intro H'.
apply H'; clear H' i; auto.
intros i h n E Phi Psi cInv h1.
inversion h1; subst; clear h1.
- inversion H0; subst; clear H0.
  (* fn case *)
  + inversion H3; subst; clear H3.
    unfold seq_,atom_;
      apply s_bc with (All (fun x:uexp => (Imp (is_exp x) (atom_ (is_exp (E0 x))))));
      auto with hybrid.
    apply s_all; auto.
    intros x h5.
    specialize (H2 x h5).
    inversion H2; subst; clear H2.
    apply s_imp; auto.
    apply h with n (varE x::Phi); eauto with hybrid; try lia.
  (* app case *)
  + inversion H3; subst; clear H3.
    unfold seq_,atom_;
      apply s_bc with (Conj (atom_ (is_exp E1)) (atom_ (is_exp E2)));
      auto with hybrid.
    apply s_and; auto.
    * apply h with N1 Phi; auto; try lia.
    * apply h with N2 Phi; auto; try lia.
  (* var case *)
  + inversion H3; subst; clear H3.
    * inversion H0; subst; clear H0.
    * specialize memb_ve2 with (1:=cInv) (2:=H2); case Psi.
      -- simpl; tauto.
      -- intros a Phi h1.
         apply s_init; auto with hybrid.
(* context case *)
- specialize memb_ve1 with (x:=E) (n:=n) (1:=cInv); intro; tauto.
Qed.

Lemma varEOcc_adeq_cor : forall (E:uexp) (n:nat),
  seq0 (atom_ (varEOcc E n)) -> seq0 (atom_ (is_exp E)).
Proof.
intros T n [i h].
generalize nil_ve; intro h2.
specialize varEOcc_adeq with (1:=h2) (2:=h); intro; exists i; auto.
Qed.

End varEOcc_adeq.