Definition id {A:Type} (x:A) : A := x.
Arguments id {A} x / .
Definition apply {A B:Type} : (A -> B) -> A -> B := id.
Arguments apply {A B} / _ _.
Definition flip {A B C:Type} (f:A -> B -> C) (y:B) (x:A) := f x y.
Arguments flip {A B C} f y x /.
Definition compose {A B C:Type} (g:B -> C) (f:A -> B) (x:A) : C := g (f x).
Arguments compose {A B C} g f x /.
Definition compose12 {A B C D:Type} : (C -> D) -> (A -> B -> C) -> A -> B -> D := compose compose compose.

Module Notation.
  Notation "'begin' e1 'end'" := ((e1)) (at level 0, only parsing).
  Notation "f $ x" := (f x) (at level 89, right associativity, only parsing).
  Notation "x ` f ` y" := (f x y) (at level 88, f at next level, right associativity, only parsing).

  Infix "∙" := compose (at level 65, right associativity).
  Infix "∙∶" := compose12 (at level 65, right associativity).
End Notation.


Require Export Syntax.
Require Import Types.

Require Import List.

(*
--------
Program
--------
*)

Inductive wfMethodSig (P : program) : methodSig -> Prop :=
  WF_Msig :
    forall m x t t',
      wfType P t ->
      wfType P t' ->
      wfMethodSig P (MethodSig m (x, t) t').

Inductive wfInterface (P : program) : interfaceDecl -> Prop :=
  | WF_Interface :
      forall i msigs,
        Forall (wfMethodSig P) msigs ->
        wfInterface P (Interface i msigs)
  | WF_ExtInterface :
      forall i i1 i2 msigs1 msigs2,
        methodSigs P (TInterface i1) msigs1 ->
        methodSigs P (TInterface i2) msigs2 ->
        (forall m msig, methodSigLookup msigs1 m = Some msig -> methodSigLookup msigs2 m = None) ->
        (forall m msig, methodSigLookup msigs2 m = Some msig -> methodSigLookup msigs1 m = None) ->
        wfInterface P (ExtInterface i i1 i2).

Inductive wfFieldDecl (P : program) : fieldDecl -> Prop :=
  | WF_Field :
      forall f t,
        wfType P t ->
        wfFieldDecl P (Field f t).

Inductive wfMethodDecl (P : program) (c : class_id) : methodDecl -> Prop :=
  | WF_Method :
      forall m x t t' e,
      wfType P t ->
      (* This should be derivable, but this makes things simpler *)
      wfType P t' ->
      x <> this ->
      (* This should also be derivable *)
      remove id_eq_dec x
             (remove id_eq_dec this (freeVars e)) = nil ->
      exprStatic e ->
        (let Gamma := extend
                        (extend empty
                                (env_var (SV x)) t)
                        (env_var (SV this)) (TClass c) in
         P ; Gamma |- e \in t') ->
        wfMethodDecl P c (Method m (x, t) t' e).

Inductive wfClassDecl (P : program) : classDecl -> Prop :=
  | WF_Class :
      forall c i fs ms msigs,
        methodSigs P (TInterface i) msigs ->
        extractSigs ms = msigs ->
        Forall (wfFieldDecl P) fs ->
        Forall (wfMethodDecl P c) ms ->
        wfClassDecl P (Cls c i fs ms).

Inductive wfProgram : program -> ty -> Prop :=
  | WF_Program :
      forall cds ids e t,
        Forall (wfClassDecl (cds, ids, e)) cds ->
        Forall (wfInterface (cds, ids, e)) ids ->
        (cds, ids, e); empty |- e \in t ->
        wfProgram (cds, ids, e) t.

(*
-------
Heap
-------
*)

Inductive wfFields (P : program) (Gamma : env) (c : class_id) (F : dyn_fields) : Prop :=
  WF_Fields :
    forall fs,
      fields P (TClass c) = Some fs ->
      (forall f t, fieldLookup fs f = Some (Field f t) ->
                   exists v, F f = Some v /\ P; Gamma |- EVal v \in t) ->
      wfFields P Gamma c F.

Inductive wfHeap (P : program) (Gamma : env) : heap -> Prop :=
  WF_Heap :
    forall H,
      wfEnv P Gamma ->
      (forall l c, Gamma (env_loc l) = Some (TClass c) ->
                   exists F L, heapLookup H l = Some (c, F, L) /\
                               wfFields P Gamma c F) ->
      (forall l, heapLookup H l <> None -> exists c, Gamma (env_loc l) = Some (TClass c)) ->
      wfHeap P Gamma H.

(*
------
Vars
------
*)

Definition freshVars (n : nat) (V : dvar_map) :=
  (forall n', n <= n' -> fresh V (DVar n')).

Inductive wfVars (P : program) (Gamma : env) (n : nat) (V : dvar_map) : Prop :=
  WF_Vars :
      wfEnv P Gamma ->
      (forall x t, Gamma (env_var (DV x)) = Some t -> exists v, V x = Some v /\ P; Gamma |- (EVal v) \in t) ->
      (forall x, V x <> None -> Gamma (env_var (DV x)) <> None) ->
      freshVars n V ->
      wfVars P Gamma n V.

(*
------
Locks
------
*)

Inductive wfLock (H : heap) : lock -> Prop :=
  | WF_Lock :
      forall l c F,
        heapLookup H l = Some (c, F, LLocked) ->
        wfLock H l.

Inductive wfHeldLocks (H : heap) (Ls : list lock) : Prop :=
  | WF_HeldLocks :
      Forall (wfLock H) Ls ->
      wfHeldLocks H Ls.

Inductive wfLocks (Ls : list lock) (e : expr) : Prop :=
  | WF_Locks :
      (forall l, In l (locks e) -> In l Ls) ->
      NoDup (locks e) ->
      wfLocks Ls e.

Inductive disjointLocks (T1 T2 : threads) : Prop :=
  | DisjointLocks :
      (forall L, In L (heldLocks T1) -> ~ In L (heldLocks T2)) ->
      (forall L, In L (heldLocks T2) -> ~ In L (heldLocks T1)) ->
      disjointLocks T1 T2.

Inductive wfLocking (H : heap) : threads -> Prop :=
  | WF_Locking_Thread :
      forall Ls e,
        wfHeldLocks H Ls ->
        NoDup Ls ->
        wfLocks Ls e ->
        wfLocking H (T_Thread Ls e)
  | WF_Locking_Async :
      forall T1 T2 e,
        wfLocks (leftmost_locks T1) e ->
        (forall L, In L (locks e) -> ~In L (t_locks T1)) ->
        disjointLocks T1 T2 ->
        wfLocking H T1 ->
        wfLocking H T2 ->
        wfLocking H (T_Async T1 T2 e)
  | WF_Locking_EXN :
      forall Ls,
        wfHeldLocks H Ls ->
        wfLocking H (T_EXN Ls).

(*
--------
Threads
--------
*)

Inductive wfThreads (P : program) (Gamma : env) : threads -> ty -> Prop :=
  | WF_Thread :
      forall Ls e t,
        freeVars e = nil ->
        P; Gamma |- e \in t ->
        wfThreads P Gamma (T_Thread Ls e) t
  | WF_Async :
      forall T1 T2 e t t1 t2,
        freeVars e = nil ->
        P; Gamma |- e \in t ->
        wfThreads P Gamma T1 t1 ->
        wfThreads P Gamma T2 t2 ->
        wfThreads P Gamma (T_Async T1 T2 e) t
  | WF_EXN :
      forall t Ls,
        wfType P t ->
        wfEnv P Gamma ->
        wfThreads P Gamma (T_EXN Ls) t.

(*
--------------
Configuration
--------------
*)

Inductive wfConfiguration (P : program) (Gamma : env) : configuration -> ty -> Prop :=
  | WF_Cfg :
      forall H V n T t,
        0 < n ->
        wfHeap P Gamma H ->
        wfVars P Gamma n V ->
        wfThreads P Gamma T t ->
        wfLocking H T ->
        wfConfiguration P Gamma (H, V, n, T) t.

github-repos/coq/beatrizagf-RC3-Coq/RC3-Coq-1df7e85168938c08c93c04ed4174c4eb53e175ca/Stage 2 - atogen/WellFormedness.v


(*

  Copyright 2016 Luxembourg University
  Copyright 2017 Luxembourg University

  This file is part of Velisarios.

  Velisarios 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.

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

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

  Authors: Vincent Rahli
           Ivana Vukotic

*)

Require Export tactics2.

Section PBFTin_iseg.

  Fixpoint In_iseg {A} (iseg : list A) (a : A) (l : list A) {struct l} : Prop :=
    match l with
    | [] => False
    | b :: bs =>
      match iseg with
      | [] => a = b
      | x :: xs => x = b /\ In_iseg xs a bs
      end
    end.

  Lemma in_iseg_prop :
    forall {A} l (iseg : list A) a,
      In_iseg iseg a l <-> exists l', l = iseg ++ (a :: l').
  Proof.
    induction l; simpl; introv.

    - split; intro h; exrepnd; tcsp.
      assert (@length A [] = length (iseg ++ a :: l')) as eqlen.
      { rewrite h0; auto. }
      simpl in eqlen.
      rewrite app_length in eqlen; simpl in eqlen.
      destruct iseg; simpl in *; ginv.

    - destruct iseg.

      + split; intro q; exrepnd; subst; tcsp; simpl in *; ginv; auto.
        exists l; simpl; auto.

      + split; intro q; repnd; subst.

        * apply IHl in q; exrepnd; subst; simpl in *.
          exists l'; dands; auto.

        * exrepnd; simpl in *; ginv.
          dands; auto.
          apply IHl.
          exists l'; auto.
  Qed.

  Fixpoint In_iseg_fseg {A} (iseg fseg : list A) (a : A) (l : list A) {struct l} : Prop :=
    match l with
    | [] => False
    | b :: bs =>
      match iseg with
      | [] => a = b /\ fseg = bs
      | x :: xs => x = b /\ In_iseg_fseg xs fseg a bs
      end
    end.

  Lemma in_iseg_fseg_prop :
    forall {A} l (iseg fseg : list A) a,
      In_iseg_fseg iseg fseg a l <-> l = iseg ++ (a :: fseg).
  Proof.
    induction l; simpl; introv.

    - split; intro h; exrepnd; tcsp.
      assert (@length A [] = length (iseg ++ a :: fseg)) as eqlen.
      { rewrite h; auto. }
      simpl in eqlen.
      rewrite app_length in eqlen; simpl in eqlen.
      destruct iseg; simpl in *; ginv.

    - destruct iseg.

      + split; intro q; exrepnd; subst; tcsp; simpl in *; ginv; auto.

      + split; intro q; repnd; subst.

        * apply IHl in q; exrepnd; subst; simpl in *; auto.

        * exrepnd; simpl in *; ginv.
          dands; auto.
          apply IHl; auto.
  Qed.

  Lemma In_iseg_implies_In :
    forall {T} (L : list T) a iseg, In_iseg iseg a L -> In a L.
  Proof.
    induction L; introv i; simpl in *; tcsp.
    destruct iseg; repnd; subst; tcsp.
    right; eapply IHL; eauto.
  Qed.
  Hint Resolve In_iseg_implies_In : list.

End PBFTin_iseg.

Hint Resolve In_iseg_implies_In : list.


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

See the COPYRIGHTS and LICENSE files.

- Frederic Blanqui, 2012-04-05

* Alpha-equivalence
*)

Set Implicit Arguments.

From Coq Require Import Wf_nat Morphisms Basics Equivalence.
From CoLoR Require Import BoolUtil RelUtil LogicUtil SN VecUtil NatUtil VecOrd.
From CoLoR Require Export LSubs.

(****************************************************************************)
(** ** Definition of alpha-equivalence

We exactly follow Curry-Feys definition (pages 59 and 91):
alpha-equivalence is defined as the smallest congruence containing the
rule [aeq_alpha] below. *)

Module Export Def.

  Section aeq.

    (** We assume given decidable sets [F] and [X] for function
    symbols and variables respectively. *)

    Variables (F X : Type)
      (eq_fun_dec : forall f g : F, {f=g}+{~f=g})
      (eq_var_dec : forall x y : X, {x=y}+{~x=y}).

    Notation Te := (@Te F X).

    (** We assume given a structure for finite sets on [X]. *)

    Variable ens_X : Ens X.

    Notation In := (Ens_In ens_X).
    Notation fv := (@fv F X ens_X).

    (** We assume that [X] is infinite. *)

    Variable var_notin : Ens_type ens_X -> X.

    Notation rename := (@rename F X eq_fun_dec eq_var_dec ens_X var_notin).

    (** Definition of alpha-equivalence. *)

    Inductive aeq : relation Te :=
    | aeq_refl : forall u, aeq u u
    | aeq_sym : forall u v, aeq u v -> aeq v u
    | aeq_trans : forall u v w, aeq u v -> aeq v w -> aeq u w
    | aeq_app_l : forall u u' v, aeq u u' -> aeq (App u v) (App u' v)
    | aeq_app_r : forall u v v', aeq v v' -> aeq (App u v) (App u v')
    | aeq_lam : forall x u u', aeq u u' -> aeq (Lam x u) (Lam x u')
    | aeq_alpha : forall x u y,
      ~In y (fv u) -> aeq (Lam x u) (Lam y (rename x y u)).

    Infix "~~" := aeq (at level 70).

    (** Alternative definition of [aeq] as the equivalence closure of
       the monotone closure of [aeq_top]. *)

    Inductive aeq_top : relation Te :=
    | aeq_top_intro : forall x u y,
      ~In y (fv u) -> aeq_top (Lam x u) (Lam y (rename x y u)).

    (** Closure modulo alpha-equivalence of a relation. *)

    Section clos_aeq.

      Variable R : relation Te.

      Inductive clos_aeq : relation Te :=
      | clos_aeq_intro :
        forall u u' v v', u ~~ u' -> v ~~ v' -> R u' v' -> clos_aeq u v.

      (** "Alpha-transitive closure" of a relation on terms:
         [S*] is the (reflexive) transitive closure of [S U aeq]. *)

      Inductive clos_aeq_trans : relation Te :=
      | at_step : forall u v, R u v -> clos_aeq_trans u v
      | at_aeq : forall u v, u ~~ v -> clos_aeq_trans u v
      | at_trans : forall u v w, clos_aeq_trans u v ->
        clos_aeq_trans v w -> clos_aeq_trans u w.

    End clos_aeq.

    (** Alpha-equivalence on vectors of terms. *)

    Notation vaeq := (Vforall2 aeq).

    (** Component-wise extension to vectors of a relation on terms,
       modulo [vaeq]. *)

    Definition clos_vaeq {n} R := vaeq @ (Vrel1 (n:=n) R @ vaeq).

  End aeq.

  Arguments aeq_alpha [F X] eq_fun_dec eq_var_dec ens_X var_notin [x u] y _.

End Def.

(****************************************************************************)
(** ** Properties of alpha-equivalence. *)

Module Make (Export L : L_Struct).

  Module Export S := LSubs.Make L.

  (** Notations for alpha-equivalence and related definitions. *)

  Notation aeq := (@aeq F X FOrd.eq_dec XOrd.eq_dec ens_X var_notin).
  Notation aeq_alpha :=
    (@aeq_alpha F X FOrd.eq_dec XOrd.eq_dec ens_X var_notin).
  Notation aeq_top := (@aeq_top F X FOrd.eq_dec XOrd.eq_dec ens_X var_notin).
  Notation clos_aeq := (@clos_aeq F X FOrd.eq_dec XOrd.eq_dec ens_X var_notin).
  Notation clos_aeq_trans :=
    (@clos_aeq_trans F X FOrd.eq_dec XOrd.eq_dec ens_X var_notin).
  Notation clos_vaeq :=
    (@clos_vaeq F X FOrd.eq_dec XOrd.eq_dec ens_X var_notin).

  Notation vaeq := (Vforall2 aeq).
  Infix "~~" := aeq (at level 70).
  Infix "~~~" := vaeq (at level 70).
  Notation "R *" := (clos_aeq_trans R) (at level 35).

  (** [aeq] is the smallest equivalence containing the monotone
  closure of [aeq_top]. *)

  Lemma aeq_equiv_mon : aeq == clos_equiv (clos_mon aeq_top).

  Proof.
    split; intros u v uv; revert u v uv.

    induction 1. refl. sym. hyp. trans v; hyp.
    clear uv. revert u u' IHuv. induction 1.
    apply e_step. apply m_app_l. hyp.
    refl. trans (App y v); hyp. sym. hyp.
    clear uv. revert v v' IHuv. induction 1.
    apply e_step. apply m_app_r. hyp.
    refl. trans (App u y); hyp. sym. hyp.
    clear uv. revert u u' IHuv. induction 1.
    apply e_step. apply m_lam. hyp.
    refl. trans (Lam x y); hyp. sym. hyp.
    apply e_step. apply m_step. apply aeq_top_intro. hyp.

    induction 1.
    revert x y H. induction 1.
    inversion H. apply aeq_alpha. hyp.
    apply aeq_app_l. hyp.
    apply aeq_app_r. hyp.
    apply aeq_lam. hyp.
    apply aeq_refl.
    apply aeq_trans with y; hyp.
    apply aeq_sym. hyp.
  Qed.

  (** [aeq] is an equivalence relation. *)

  Global Instance aeq_equiv : Equivalence aeq.

  Proof. rewrite aeq_equiv_mon. apply ec_equiv. Qed.

  (*COQ: cannot be removed?*)
  Global Instance aeq_preorder : PreOrder aeq.

  Proof. split; class. Qed.

  (** [aeq] is monotone. *)

  Global Instance aeq_mon : Monotone aeq.

  Proof. rewrite aeq_equiv_mon. class. Qed.

  (** Term constructors are compatible with [aeq]. *)

  Global Instance App_aeq : Proper (aeq ==> aeq ==> aeq) App.

  Proof.
    intros u1 v1 u1v1 u2 v2 u2v2. trans (App u1 v2).
    apply aeq_app_r. hyp. apply aeq_app_l. hyp.
  Qed.

  Global Instance Lam_aeq : Proper (Logic.eq ==> aeq ==> aeq) Lam.

  Proof. intros x x' xx' u u' uu'. subst x'. apply aeq_lam. hyp. Qed.

  (** Basic lemmas. *)

  Lemma aeq_refl_eq : forall u v, u = v -> u ~~ v.

  Proof. intros u v e. subst v. apply aeq_refl. Qed.

  Lemma aeq_alpha' : forall x u y,
    x = y \/ ~In y (fv u) -> Lam x u ~~ Lam y (rename x y u).

  Proof.
    intros x u y [h|h]. subst. rewrite rename_id. refl. apply aeq_alpha. hyp.
  Qed.

  (** [fv] is compatible with [aeq]. *)

  Global Instance fv_aeq : Proper (aeq ==> Equal) fv.

  Proof.
    induction 1; simpl.
    refl.
    sym. hyp.
    rewrite IHaeq1, IHaeq2. refl.
    rewrite IHaeq. refl.
    rewrite IHaeq. refl.
    rewrite IHaeq. refl.
    rewrite fv_rename; unfold replace.
    case_eq (mem x (fv u)); [rewrite <- mem_iff|rewrite <- not_mem_iff];
      intro hx.
    rewrite remove_add. refl. set_iff. tauto.
    rewrite !remove_equal; auto. refl.
  Qed.

  (** [var] is compatible with [aeq]. *)

  Global Instance var_aeq : Proper (Logic.eq ==> aeq ==> Logic.eq ==> Logic.eq) var.

  Proof.
    intros x x' xx' u u' uu' s s' ss'. subst s'. subst x'. unfold Def.var; ens.
    rewrite uu'. destruct (mem x (fvcodom (remove x (fv u')) s)).
    rewrite uu'. refl. refl.
  Qed.

  (** On variables and function symbols, alpha-equivalence is
  equivalent to equality. *)

  Global Instance var_aeq_l : VarInvL aeq.

  Proof.
    split. intro x.
    cut (forall u v, u ~~ v -> (u = Var x \/ v = Var x) -> u = v). fo.
    induction 1; intro h; try (destruct h; discr). refl. fo. trans v.
    apply IHaeq1. destruct h as [h|h]. auto. subst. right. fo.
    apply IHaeq2. destruct h as [h|h]. subst. left. fo. auto.
  Qed.

  Global Instance var_aeq_r : VarInvR aeq.

  Proof. class. Qed.

  Lemma fun_aeq_l : forall f v, Fun f ~~ v -> Fun f = v.

  Proof.
    intro f. cut (forall u v, u ~~ v -> (u = Fun f \/ v = Fun f) -> u = v). fo.
    induction 1; intro h; try (destruct h; discr). refl. fo. trans v.
    apply IHaeq1. destruct h as [h|h]. auto. subst. right. fo.
    apply IHaeq2. destruct h as [h|h]. subst. left. fo. auto.
  Qed.

  Lemma fun_aeq_r : forall f v, v ~~ Fun f -> v = Fun f.

  Proof. intros x v h. sym. apply fun_aeq_l. sym. hyp. Qed.

  (** Tactic for simplifying alpha-equivalence assumptions on
  variables and function symbols. *)

  Ltac simpl_aeq := repeat
    match goal with
      | h : Var _ ~~ _ |- _ => apply var_aeq_l in h
      | h : _ ~~ Var _ |- _ => apply var_aeq_r in h
      | h : Fun _ ~~ _ |- _ => apply fun_aeq_l in h
      | h : _ ~~ Fun _ |- _ => apply fun_aeq_r in h
    end.

  (** Inversion lemma for alpha-equivalence on an application. *)

  Lemma app_aeq_r : forall t v1 v2, t ~~ App v1 v2 ->
    exists u1 u2, t = App u1 u2 /\ u1 ~~ v1 /\ u2 ~~ v2.

  Proof.
    cut (forall t u, t ~~ u -> forall v1 v2, (t = App v1 v2 \/ u = App v1 v2) ->
      exists u1 u2, u1 ~~ v1 /\ u2 ~~ v2
        /\ (t = App v1 v2 -> u = App u1 u2)
        /\ (u = App v1 v2 -> t = App u1 u2)).
    intros h v u1 u2 e. assert (p : v = App u1 u2 \/ App u1 u2 = App u1 u2).
    tauto. destruct (h _ _ e _ _ p) as [a [b [h1 [h2 [h3 h4]]]]].
    ex a b. intuition.
    induction 1; intros u1 u2 e.
    (* refl *)
    ex u1 u2. firstorder auto with crelations.
    (* sym *)
    rewrite or_sym in e. destruct (IHaeq _ _ e) as [a [b [h1 [h2 [h3 h4]]]]].
    ex a b. fo.
    (* trans *)
    destruct e.
    assert (p1 : u = App u1 u2 \/ v = App u1 u2). tauto.
    destruct (IHaeq1 _ _ p1) as [a [b [h1 [h2 [h3 h4]]]]].
    assert (p2 : v = App a b \/ w = App a b). tauto.
    destruct (IHaeq2 _ _ p2) as [c [d [i1 [i2 [i3 i4]]]]].
    ex c d. split_all; subst; try inversion H4; try inversion H5;
              try inversion H6; try inversion H2; subst; auto;
                try (trans a; hyp); try (trans b; hyp).
    assert (p2 : v = App u1 u2 \/ w = App u1 u2). tauto.
    destruct (IHaeq2 _ _ p2) as [a [b [h1 [h2 [h3 h4]]]]].
    assert (p1 : u = App a b \/ v = App a b). tauto.
    destruct (IHaeq1 _ _ p1) as [c [d [i1 [i2 [i3 i4]]]]].
    ex c d. split_all; subst; try inversion H2; try inversion H4;
              try inversion H5; subst; auto;
                try (trans a; hyp); try (trans b; hyp).
    (* app_l *)
    destruct e as [h|h]; inversion h; subst; clear h.
    ex u' u2. firstorder auto with crelations. ex u u2. firstorder auto with crelations.
    (* app_r *)
    destruct e as [h|h]; inversion h; subst; clear h.
    ex u1 v'. firstorder auto with crelations. ex u1 v. firstorder auto with crelations.
    (* lam *)
    destruct e; discr.
    (* alpha *)
    destruct e; discr.
  Qed.

  Lemma app_aeq_l : forall v1 v2 t, App v1 v2 ~~ t ->
    exists u1 u2, t = App u1 u2 /\ u1 ~~ v1 /\ u2 ~~ v2.

  Proof. intros v1 v2 t e. apply app_aeq_r. sym. hyp. Qed.

  (** [size] is compatible with [aeq]. *)

  Global Instance size_aeq : Proper (aeq ==> Logic.eq) size.

  Proof.
    intro u; revert u; induction 1; simpl.
    refl.
    auto.
    trans (size v); hyp.
    rewrite IHaeq. refl.
    rewrite IHaeq. refl.
    rewrite IHaeq. refl.
    rewrite size_rename. refl.
  Qed.

  (** Every term is alpha-equivalent to a term which bound variables
  are disjoint from some given finite set (CF, Theorem 2b, page 95). *)

  Lemma aeq_notin_bv : forall xs u,
    exists v, u ~~ v /\ inter (bv v) xs [=] empty.

  Proof.
    intro xs. induction u.
    (* var *)
    ex (Var x). split. refl. simpl. rewrite inter_empty_l. refl.
    (* fun *)
    ex (Fun f). split. refl. simpl. rewrite inter_empty_l. refl.
    (* app *)
    destruct IHu1 as [v1 [h1 i1]]. destruct IHu2 as [v2 [h2 i2]].
    ex (App v1 v2). split.
    trans (App v1 u2). apply aeq_app_l. hyp. apply aeq_app_r. hyp.
    simpl. rewrite union_inter_1, i1, i2, union_empty_l. refl.
    (* lam *)
    destruct IHu as [v [h i]].
    set (uxs := union (fv v) (union (bv v) xs)).
    set (x' := var_notin uxs). ex (Lam x' (rename x x' v)).
    gen (var_notin_ok uxs). fold x'. unfold uxs. set_iff. intro n. split.
    trans (Lam x v). apply aeq_lam. hyp. apply aeq_alpha. tauto.
    simpl. rewrite bv_rename. 2: tauto. revert i. rewrite inter_sym at 1.
    rewrite !inter_empty. unfold not. intros i z. set_iff. intros [j|j].
    subst z. tauto. intro hz. eapply i. apply hz. hyp.
  Qed.

  (** Compatibility with [aeq] is preserved by [clos_trans]. *)

  Lemma clos_trans_aeq R :
    Proper (aeq ==> aeq ==> impl) R -> Proper (aeq ==> aeq ==> impl) (R!).

  Proof.
    intros R_aeq t t' tt' u u' uu' tu.
    revert t u tu t' tt' u' uu'; induction 1; intros t' tt' u' uu'.
    apply t_step. rewrite <- tt', <- uu'. hyp. trans y; firstorder auto with crelations.
  Qed.

(****************************************************************************)
(** ** Alpha-equivalence on substitutions. *)

  Notation saeq := (subs_rel aeq).

  Global Instance fvcodom_saeq xs : Proper (saeq xs ==> Equal) (fvcodom xs).

  Proof.
    intros s s' ss'. eapply fvcodom_subs_rel_Equal.
    apply fv_aeq. class. class. hyp.
  Qed.

  Global Instance var_saeq x u :
    Proper (saeq (remove x (fv u)) ==> Logic.eq) (var x u).

  Proof. eapply var_subs_rel; class. Qed.

  Arguments var_saeq [x u s s'] _ : rename.

  Lemma subs_saeq u s s' : saeq (fv u) s s' -> subs s u ~~ subs s' u.

  Proof. intro ss'. apply subs_rel_mon_preorder; class. Qed.

  Arguments subs_saeq [u s s'] _.

  Lemma subs1_saeq u s s' : saeq (fv u) s s' -> subs1 s u ~~ subs1 s' u.

  Proof. intro ss'. apply subs1_rel_mon_preorder; class. Qed.

  Arguments subs1_saeq [u s s'] _.

  (** Generalization of [aeq_notin_bv] (Theorem 2b in CF) to
  substitutions: every substitution [s] is alpha-equivalent on any
  finite set [xs] to a substitution [s'] which domain is included in
  [xs] and which bound variables are disjoint from any fixed set
  [ys]. *)

  Lemma saeq_notin_bvcodom : forall ys s xs, exists s', saeq xs s s'
    /\ inter (bvcod xs s') ys [=] empty /\ dom_incl xs s'.

  Proof.
    intros ys s. apply set_induction_bis.
    (* Equal *)
    intros xs xs' e [s' [ss' [h1 h2]]]. ex s'. rewrite <- e. auto.
    (* empty *)
    ex id.
    split; try split; intro x; try rewrite bvcod_empty; set_iff; tauto.
    (* add *)
    intros x xs n [s' [ss' [h1 h2]]].
    destruct (aeq_notin_bv ys (s x)) as [u [i1 i2]]. ex (update x u s').

    split. intro y. set_iff. unfold Def.update. eq_dec y x.
    subst y. intros. hyp. intros [i|i]. subst y. tauto. apply ss'. hyp.

    split. rewrite inter_sym, inter_empty. intros y hy. rewrite In_bvcod.
    intros [z [j1 j2]]. revert j1 j2. set_iff. unfold Def.update.
    eq_dec z x.
    subst z. intros _ h'. rewrite inter_empty in i2. eapply i2. apply h'. hyp.
    intros [h3|h3] h4. subst z. tauto. rewrite inter_sym, inter_empty in h1.
    absurd (In y (bvcod xs s')). apply h1. hyp.
    rewrite In_bvcod. ex z. tauto.

    intro y. set_iff. intro hy. unfold Def.update. eq_dec y x.
    subst y. tauto. apply h2. tauto.
  Qed.

(****************************************************************************)
(** ** Some meta-theorems. *)

  (** Meta-theorem saying that, for proving [subs s u ~~ subs s v], we
  can assume without lost of generality (w.l.o.g.) that the domain of
  [s] is included in [union (fv u) (fv v)]. *)

  Lemma restrict_domain_subs_aeq : forall u v,
    (forall s, (forall x, ~In x (union (fv u) (fv v)) -> s x = Var x) ->
      subs s u ~~ subs s v) -> forall s, subs s u ~~ subs s v.

  Proof.
    intros u v h s. set (s' := restrict (union (fv u) (fv v)) s).
    rewrite subs_seq with (s':=s'). rewrite subs_seq with (s:=s) (s':=s').
    apply h. intros x h'. unfold s', Def.restrict; ens.
    rewrite not_mem_iff in h'. rewrite h'. refl.
    unfold s'. apply seq_restrict. apply union_subset_2.
    unfold s'. apply seq_restrict. apply union_subset_1.
  Qed.

  (** Meta-theorem saying that, for proving [subs s u ~~ subs s v], we
  can assume w.l.o.g. that the bound variables of [s] are disjoint
  from some fixed finite set [ys]. *)

  Lemma restrict_bvcodom_subs_aeq : forall ys u v,
    (forall s, dom_incl (union (fv u) (fv v)) s ->
      inter (bvcod (union (fv u) (fv v)) s) ys [=] empty ->
      subs s u ~~ subs s v) -> forall s, subs s u ~~ subs s v.

  Proof.
    intros ys u v h s.
    destruct (saeq_notin_bvcodom ys s (union (fv u) (fv v)))
      as [s' [h1 [h2 h3]]].
    rewrite subs_saeq with (s':=s'). rewrite subs_saeq with (s:=s) (s':=s').
    apply h; hyp.
    eapply subs_rel_s. refl. unfold flip. eapply union_subset_2. refl. refl.
    apply h1.
    eapply subs_rel_s. refl. unfold flip. eapply union_subset_1. refl. refl.
    apply h1.
  Qed.

  (** Meta-theorem saying that, for proving [P s -> subs s u ~~ subs s v],
  we can assume w.l.o.g. that the domain of [s] is included in
  [union (fv u) (fv v)], and the bound variables of [s] are disjoint
  from some fixed finite set [ys s], if [P] and [ys] are compatible
  with [saeq (union (fv u) (fv v))]. *)

  Lemma restrict_bvcodom_subs_aeq_prop : forall u v ys P,
    Proper (saeq (union (fv u) (fv v)) ==> Equal) ys ->
    Proper (saeq (union (fv u) (fv v)) ==> iff) P ->
    (forall s, dom_incl (union (fv u) (fv v)) s ->
      inter (bvcod (union (fv u) (fv v)) s) (ys s) [=] empty ->
      P s -> subs s u ~~ subs s v) -> forall s, P s -> subs s u ~~ subs s v.

  Proof.
    intros u v ys P hys hP h s hs.
    destruct (saeq_notin_bvcodom (ys s) s (union (fv u) (fv v)))
      as [s' [h1 [h2 h3]]].
    rewrite subs_saeq with (s':=s'). rewrite subs_saeq with (s:=s) (s':=s').
    apply h. hyp. rewrite <- h1 at 2. hyp. rewrite <- h1. hyp.
    eapply subs_rel_s. refl. unfold flip. eapply union_subset_2. refl. refl.
    apply h1.
    eapply subs_rel_s. refl. unfold flip. eapply union_subset_1. refl. refl.
    apply h1.
  Qed.

(****************************************************************************)
(** ** Substitution is compatible with alpha-equivalence
(CF, Theorem 2a, page 95, proof pages 100-103).

This is the most difficult theorem when formalizing lambda-calculus
using Curry and Feys approach. The CF paper proof has about 100 lines
and the following Coq proof has about 200 lines, but it could
certainly be shortened by defining tactics for reasoning on free
variables. *)

  Global Instance subs_aeq : Proper (Logic.eq ==> aeq ==> aeq) subs.

  Proof.
    intros s s' ss'. subst s'. intros u u' uu'; revert u u' uu' s.
    (* As CF, we proceed first by induction on the size of [u],
       and second by induction on [u ~~ u']. *)
    intro u; pattern u; apply (induction_ltof1 size); clear u.
    intros u IH u' uu'; revert u u' uu' IH. induction 1; intros IH s.
    (* refl *)
    refl.
    (* sym *)
    sym. apply IHuu'. intros w hw w' ww' s'. apply IH.
    unfold ltof. rewrite <- uu'. hyp. hyp.
    (* trans *)
    trans (subs s v).
    apply IHuu'1. intros a ha a' aa' s'. apply IH. hyp. hyp.
    apply IHuu'2. intros a ha a' aa' s'. apply IH.
    unfold ltof. rewrite uu'1. hyp. hyp.
    (* app_l *)
    simpl. apply aeq_app_l. apply IHuu'. intros a ha a' aa' s'. apply IH.
    revert ha. unfold ltof. simpl. max. hyp.
    (* app_r *)
    simpl. apply aeq_app_r. apply IHuu'. intros a ha a' aa' s'. apply IH.
    revert ha. unfold ltof. simpl. max. hyp.
    (* lam *)
    simpl.
    rewrite (@var_aeq _ _ (Logic.eq_refl x) _ _ uu' _ _ (Logic.eq_refl s)).
    set (x' := var x u' s). set (s' := update x (Var x') s). apply aeq_lam.
    apply IHuu'. intros v hv v' vv' l. apply IH.
    revert hv. unfold ltof. simpl. intro hv. lia. hyp.
    (* alpha *)
    eq_dec x y.
    (* x = y *)
    subst. rewrite rename_id. refl.
    (* x <> y *)
    set (u' := rename x y u).

    assert (pp' : remove x (fv u) [=] remove y (fv u')).
    unfold u'. rewrite fv_rename; unfold replace.
    case_eq (mem x (fv u)); [rewrite <- mem_iff|rewrite <- not_mem_iff];
      intro h. rewrite remove_add. refl. set_iff. intuition.
    rewrite !remove_equal; auto. refl.

    destruct (aeq_notin_bv (add (var y u' s) (add (var x u s)
      (add x (add y (union (fv u) (fvcodom (remove x (fv u)) s)))))) u)
      as [v [h1 h2]]. rewrite inter_sym in h2. revert s h2.
    apply restrict_bvcodom_subs_aeq_prop
      with (ys := fun s => singleton (var y u' s)).

    intros s s'. simpl. rewrite <- pp', union_idem. intro ss'.
    rewrite var_saeq. refl. rewrite <- pp'. hyp.

    intros s s'. simpl. rewrite <- pp', union_idem. intro ss'.
    rewrite (fvcodom_saeq ss'), (var_saeq ss').
    rewrite pp' in ss'. rewrite (var_saeq ss'). refl.

    intro s. simpl. set (x' := var x u s). set (y' := var y u' s).
    set (xs := add y' (add x' (add x (add y (union (fv u)
      (fvcodom (remove x (fv u)) s)))))). rewrite <- pp', union_idem.
    intros hs1 hs2 hs3.
    set (xx's := update x (Var x') s). set (yy's := update y (Var y') s).

    trans (Lam x' (subs xx's v)). apply aeq_lam. apply IH.
    unfold ltof. simpl. lia. hyp.
    unfold u'. trans (Lam y' (subs yy's (rename x y v))).

    2:{ apply aeq_lam. apply IH.
    unfold ltof. rewrite h1, size_rename. simpl. lia.
    apply IH. unfold ltof. rewrite h1. simpl. lia. sym. hyp. }

    rewrite inter_sym, inter_empty in hs3. unfold xs in hs3.
    rewrite <- eqb_false_iff, eqb_sym in n.

    assert (e : rename x y v = subs1 (single x (Var y)) v).
    unfold Def.rename. apply subs1_no_alpha.
    rewrite fvcodom_single, beq_term_var, n.
    simpl. rewrite andb_true_r. destruct (mem x (fv v)). 2: apply inter_empty_r.
    rewrite inter_empty. intros a ha. set_iff. intro e. subst a.
    eapply hs3. apply ha. set_iff. tauto.

    assert (e1 : subs xx's v = subs1 xx's v). apply subs1_no_alpha.
    rewrite inter_empty. intros a ha. rewrite In_fvcodom.
    intros [b [i1 [i2 i3]]]. gen (hs3 _ ha). set_iff. split_all.
    apply H5. rewrite In_fvcodom. ex b. set_iff. rewrite h1.
    revert i3. unfold xx's. unfold Def.update. eq_dec b x.
    subst b. simpl. set_iff. tauto.
    split_all. revert i3. rewrite H6. simpl.
    set_iff. intro h. subst b. rewrite h1 in H4. tauto.

    assert (e2 : subs yy's (rename x y v) = subs1 yy's (rename x y v)).
    apply subs1_no_alpha. rewrite bv_rename.
    2:{ intro h. gen (hs3 _ h). set_iff. tauto. }
    rewrite inter_empty. intros a ha. gen (hs3 _ ha). set_iff. split_all.
    revert H1. rewrite In_fvcodom. intros [b [i1 [i2 i3]]]. revert i2 i3.
    unfold yy's. unfold Def.update. eq_dec b y; simpl; set_iff. auto.
    intros i2 i3. apply H6. rewrite In_fvcodom. ex b. revert i1.
    rewrite h1 in *. rewrite fv_rename; unfold replace.
    destruct (mem x (fv v)); set_iff; split_all. subst b. cong. firstorder auto with set.

    rewrite e1, e2, e. unfold yy's. rewrite subs1_update_single.
    2:{ intro h. gen (hs3 _ h). set_iff. tauto. }
    destruct (In_dec y' (fv (subs1 xx's v))).

    (* In y' (fv (subs1 xx's v)) *)
    rewrite <- e1, fv_subs in i. revert i. simpl. set_iff. rewrite In_domain.
    split_all.

    (* 1 *)
    case_eq (mem y (fvcodom (remove y (fv u')) s)); intro h.
    2:{ revert H0. unfold y', Def.var; ens. rewrite h. rewrite h1 in H.
    tauto. }
    assert (p0 : ~In y' (union (fv u') (fvcodom (remove y (fv u')) s))).
    unfold y', Def.var; ens. rewrite h. apply var_notin_ok.
    destruct (eq_term_dec (xx's y') (Var y')). 2: tauto.
    revert e0. unfold xx's at 1. unfold Def.update at 1. eq_dec y' x.

    (* y' = x *)
    intro e3. inversion e3. rewrite H3, e0. apply aeq_lam. apply aeq_refl_eq.
    apply subs1_seq. intros a ha. unfold xx's, Def.single, Def.update.
    eq_dec a x. rewrite e3, e0. refl.
    eq_dec a y. subst a. rewrite <- h1 in ha. tauto. refl.

    (* y' <> x *)
    absurd (In y' (fv u')). intro h'. apply p0. set_iff. auto.
    unfold u'. rewrite fv_rename; unfold replace. rewrite <- h1 in H0.
    destruct (mem x (fv u)). set_iff. split_all. hyp.

    (* 2 *)
    change (In y' (fvcodom (fv v) xx's)) in H0. revert H0. rewrite In_fvcodom.
    intros [a [i1 [i2 i3]]]. unfold xx's, Def.update in i2, i3.
    revert i2 i3. eq_dec a x.

    (* a = x *)
    subst a. simpl. set_iff. intros i2 i3. rewrite <- i3. apply aeq_lam.
    apply aeq_refl_eq. apply subs1_seq. intros a ha.
    unfold xx's, Def.single, Def.update.
    eq_dec a x. refl. eq_dec a y. subst a. rewrite h1 in H. tauto. refl.

    (* a <> x *)
    intros i2 i3. case_eq (mem y (fvcodom (remove y (fv u')) s)); intro hy.

    absurd (In y' (union (fv u') (fvcodom (remove y (fv u')) s))).
    unfold y', Def.var; ens. rewrite hy. apply var_notin_ok.
    set_iff. right. rewrite In_fvcodom. ex a. set_iff. split_all.
    unfold u'. rewrite fv_rename; unfold replace.
    destruct (mem x (fv u)); rewrite h1.
    set_iff. split_all. hyp. subst a. rewrite <- h1 in i1. tauto.

    assert (p0 : y' = y). unfold y', Def.var; ens. rewrite hy. refl.
    absurd (In y (fvcodom (remove y (fv u')) s)). rewrite not_mem_iff. hyp.
    rewrite In_fvcodom. ex a. set_iff. rewrite p0 in i3. split_all.
    unfold u'. rewrite fv_rename; unfold replace.
    destruct (mem x (fv u)); rewrite h1.
    set_iff. intuition. hyp. subst a. rewrite <- h1 in i1. tauto.

    (* ~In y' (fv (subs1 xx's v)) *)
    trans (Lam y' (rename x' y' (subs1 xx's v))). apply aeq_alpha. hyp.
    apply aeq_lam. unfold Def.rename. rewrite subs1_no_alpha.

    2:{ rewrite fvcodom_single, beq_term_var.
    case_eq (mem x' (fv (subs1 xx's v)) && negb (eqb y' x')).
    2: intros _; apply inter_empty_r.
    rewrite andb_true_iff, negb_true_iff, eqb_false_iff, <- mem_iff.
    intros [i1 i2]. simpl. rewrite inter_sym, inter_empty. intro a. set_iff.
    intro ha. subst a. intro h. apply bv_subs1 in h. revert h. set_iff.
    rewrite In_bvcod. intros [h|[z [j1 j2]]].
    gen (hs3 _ h). set_iff. tauto.
    revert j2. unfold xx's. eq_dec z x.
    subst z. rewrite update_eq. simpl. set_iff. auto.
    rewrite update_neq. 2: auto.
    assert (h : In z (remove x (fv u))). rewrite h1. set_iff. auto.
    intro i. rewrite inter_sym, inter_empty in hs2. eapply hs2. set_iff. refl.
    rewrite In_bvcod. ex z. auto. }

    unfold xx's. apply aeq_refl_eq.

    destruct (In_dec x' (fv v)).
    case_eq (mem x (fvcodom (remove x (fv u)) s)); intro hx.
    absurd (In x' (union (fv u) (fvcodom (remove x (fv u)) s))).
    unfold x', Def.var; ens. rewrite hx. apply var_notin_ok.
    set_iff. rewrite h1. auto.
    assert (p : x'=x). unfold x', Def.var; ens. rewrite hx. refl.
    rewrite p, subs1_single_subs1. apply subs1_seq. intros a ha.
    unfold Def.update. eq_dec a x. refl. eq_dec a y.
    subst a. rewrite <- h1 in ha. tauto. refl. rewrite update_eq. refl.
    rewrite fvcodom_update_id, <- h1, not_mem_iff. hyp.

    eq_dec x' y'. rewrite <- e0. rewrite subs1_single_id.
    apply subs1_seq. intros a ha. unfold Def.update.
    eq_dec a x. refl. eq_dec a y.
    subst a. rewrite <- h1 in ha. tauto. refl.

    rewrite subs1_single_update. apply subs1_seq. intros a ha.
    unfold Def.update. eq_dec a x'; eq_dec a x; eq_dec a y;
      try subst a; try subst x; try subst y; auto.
    tauto. rewrite <- h1 in ha. tauto. hyp.
    intro h. case_eq (mem x (fvcodom (remove x (fv u)) s)); intro hx.
    assert (p : ~In x' (union (fv u) (fvcodom (remove x (fv u)) s))).
    unfold x', Def.var; ens. rewrite hx. apply var_notin_ok.
    apply p. set_iff. right. rewrite h1. hyp.
    assert (p : x' = x). unfold x', Def.var; ens. rewrite hx. refl.
    absurd (In x' (fvcodom (remove x (fv u)) s)).
    rewrite p, not_mem_iff. hyp. rewrite h1. hyp.
    intro h. gen (hs3 _ h). set_iff. tauto.
    intro h. gen (hs3 _ h). set_iff. tauto.
  (*SLOW*)Qed.

  (** [fun u v => subs (single x u) v] is compatible with [aeq]. *)

  Global Instance subs_single_aeq :
    Proper (Logic.eq ==> aeq ==> aeq ==> aeq) subs_single.

  Proof.
    intros x x' xx' u u' uu' v v' vv'. subst x'.
    unfold Def.subs_single. rewrite <- vv'. clear v' vv'. apply subs_saeq.
    intros y _. unfold Def.single, Def.update, Def.id. eq_dec y x. hyp. refl.
  Qed.

(****************************************************************************)
(** [comp] is compatible with [saeq]. *)

  Lemma comp_saeq : forall xs s1 t1, saeq xs s1 t1 -> forall s2 t2,
    saeq (fvcod xs s1) s2 t2 -> saeq xs (comp s2 s1) (comp t2 t1).

  Proof.
    intros xs s1 t1 e1 s2 t2 e2 x hx. unfold Def.comp. rewrite (e1 _ hx).
    apply subs_saeq. intros y hy. apply e2. rewrite In_fvcod. ex x.
    rewrite (e1 _ hx). auto.
  Qed.

(****************************************************************************)
(** ** Correctness of substitution composition modulo alpha-equivalence.

Because [subs s u] may rename some bound variables of [u] depending on
the free variables of [u] and the free variables of [s], the following
equality cannot hold syntactically. Take for instance [x<>y], [u = Lam
y (Var x)], [s1 = single x (Var y)] and [s2 = single y (Var x)]. Then,
[subs s2 (subs s1 u) = subs s2 (Lam y' (Var y)) = Lam y'' (Var x)],
while [subs (comp s1 s2) u = Lam y (Var x)] since [comp s1 s2 x = s2 y
= Var x]. And one can define [var_notin] so that [y''<>y]. *)

  Lemma subs_comp u s1 s2 : subs s2 (subs s1 u) ~~ subs (comp s2 s1) u.

  Proof.
    set (A := fvcodom (fv u) s1).
    set (B := fvcodom (fv (subs s1 u)) s2).
    set (C := fvcodom (fv u) (comp s2 s1)).
    set (D := fvcodom (fvcod (fv u) s1) s2).
    set (P := union A (union B C)). set (Q := union B D).
    destruct (aeq_notin_bv P u) as [u' [uu' hu']]. rewrite uu'.
    destruct (saeq_notin_bvcodom Q s1 (fv u')) as [s1' [e1 [h1 h2]]].
    rewrite (subs_saeq e1).

    assert (a : subs s1' u' = subs1 s1' u'). apply subs1_no_alpha.
    rewrite <- e1. rewrite <- uu' at 2. fold A.
    rewrite empty_subset, union_subset_1 with (s:=A) (s':=union B C),
      <- empty_subset. hyp.

    assert (b : subs s2 (subs s1' u') = subs1 s2 (subs s1' u')).
    apply subs1_no_alpha. rewrite <- (subs_saeq e1), <- uu' at 2. fold B.
    rewrite a. rewrite empty_subset, bv_subs1, <- empty_subset. dnf.
    rewrite union_empty. split.
    rewrite empty_subset, union_subset_1 with (s:=B) (s':=union A C),
      <- empty_subset, <- union_assoc, union_sym with (s:=B), union_assoc. hyp.
    rewrite empty_subset, union_subset_1 with (s:=B) (s':=D),
      <- empty_subset. hyp.

    assert (c : subs (comp s2 s1) u' = subs1 (comp s2 s1) u').
    apply subs1_no_alpha. rewrite <- uu' at 2. fold C.
    rewrite empty_subset, union_subset_1 with (s:=C) (s':=union A B),
      <- empty_subset, union_sym with (s:=C), union_assoc. hyp.

    rewrite b, a, c, subs1_comp.

    2:{ rewrite <- e1. rewrite <- uu' at 2. fold A.
    rewrite empty_subset, union_subset_1 with (s:=A) (s':=union B C),
      <- empty_subset. hyp. }

    apply subs1_saeq. intros x hx. unfold Def.comp1, Def.comp.
    rewrite (e1 _ hx). sym. apply aeq_refl_eq. apply subs1_no_alpha.
    assert (d : bv (s1' x) [<=] bvcod (fv u') s1').
    intros y hy. rewrite In_bvcod. ex x. auto.
    assert (e : fv (s1' x) [<=] fvcod (fv u') s1').
    intros y hy. rewrite In_fvcod. ex x. auto.
    rewrite empty_subset, d, e. rewrite <- e1 at 2. rewrite <- uu' at 2.
    fold D. rewrite union_subset_1 with (s:=D) (s':=B), union_sym,
      <- empty_subset. hyp.
  Qed.

  Lemma single_rename x y u v : x = y \/ ~In y (fv u) ->
    subs (single y v) (rename x y u) ~~ subs (single x v) u.

  Proof.
    intro hy. unfold Def.rename. rewrite subs_comp. apply subs_saeq.
    intros d hd. unfold Def.comp, Def.single. unfold Def.update at -1.
    eq_dec d x; simpl.
    rewrite update_eq. refl.
    unfold Def.update. eq_dec d y. 2: refl.
    subst d. assert (n':x<>y). auto. tauto.
  Qed.

  Lemma rename2 : forall x y z u, x = y \/ ~In y (fv u) ->
    rename y z (rename x y u) ~~ rename x z u.

  Proof. intros x y z u hy. apply single_rename. hyp. Qed.

  Lemma subs_update x y s u : s y = Var y ->
    subs (update x (Var y) s) u ~~ subs (update x (Var x) s) (rename x y u).

  Proof.
    intro h. unfold Def.rename. rewrite subs_comp. apply subs_saeq.
    intros z hz. unfold Def.comp, Def.single. unfold Def.update at -2.
    eq_dec z x; simpl.
    subst. unfold Def.update. eq_dec y x.
    subst. refl.
    rewrite h. refl.
    unfold Def.update. eq_dec z x.
    subst. tauto.
    refl.
  Qed.

(****************************************************************************)
(** Given [u], [fun s => subs s u] is compatible with [subs_rel R (fv u)]. *)

  Lemma subs_rel_mon_preorder_aeq R :
    PreOrder R -> Monotone R -> Proper (aeq ==> aeq ==> impl) R ->
    forall u s s', subs_rel R (fv u) s s' -> R (subs s u) (subs s' u).

  Proof.
    intros R_refl_trans R_mon R_aeq. induction u; intros s s' h.
    (* var *)
    simpl. apply h; simpl. set_iff. refl.
    (* fun *)
    refl.
    (* app *)
    simpl. destruct R_mon.
    rewrite IHu1 with (s:=s) (s':=s'), IHu2 with (s:=s) (s':=s'). refl.
    intros x hx. apply h. simpl. apply union_subset_2. hyp.
    intros x hx. apply h. simpl. apply union_subset_1. hyp.
    (* lam *)
    rewrite subs_seq_restrict, subs_seq_restrict with (s:=s').
    set (xs := fv (Lam x u)).
    set (s1 := restrict xs s). set (s1' := restrict xs s').
    set (ys := union xs (union (fvcodom xs s1) (fvcodom xs s1'))).
    gen (var_notin_ok ys). set (z := var_notin ys). intro hz.
    rewrite aeq_alpha' with (y:=z).
    2:{ revert hz. unfold ys. unfold xs at 1. simpl. set_iff. tauto. }
    set (u' := rename x z u).

    assert (e : remove z (fv u') [=] xs).
    unfold xs, u'. rewrite fv_rename; unfold replace. simpl.
    case_eq (mem x (fv u)); intros hx a; set_iff; split_all; subst a. cong.
    revert hz. unfold ys. unfold xs at 1. simpl. set_iff. tauto.
    rewrite <- not_mem_iff in hx. contr.
    revert hz. unfold ys. unfold xs at 1. simpl. set_iff. tauto.

    rewrite subs_lam_no_alpha.
    2:{ rewrite e. revert hz. unfold ys. set_iff. tauto. }
    rewrite subs_lam_no_alpha.
    2:{ rewrite e. revert hz. unfold ys. set_iff. tauto. }

    clear e. mon. unfold u', Def.rename. rewrite !subs_comp. apply IHu.
    intros a ha. unfold Def.single, Def.comp. unfold Def.update at 2.
    unfold Def.update at 3. unfold Def.id. eq_dec a x.

    subst a. simpl. rewrite !update_eq. refl.
    simpl. unfold Def.update. eq_dec a z. refl.
    unfold s1, s1', Def.restrict; ens.
    assert (e : mem a xs = true).
    rewrite <- mem_iff. unfold xs. simpl. set_iff. fo.
    rewrite e. apply h. rewrite mem_iff. hyp.
  Qed.

  Global Instance subs_single_mon_preorder_aeq R :
    PreOrder R -> Monotone R -> Proper (aeq ==> aeq ==> impl) R ->
    Proper (Logic.eq ==> R ==> aeq ==> R) subs_single.

  Proof.
    intros P_qo R_mon R_aeq x x' xx' u u' uu' v v' vv'. subst x'.
    unfold Def.subs_single. rewrite <- vv'. clear v' vv'.
    apply subs_rel_mon_preorder_aeq; class.
    intros y _. unfold Def.single, Def.update, Def.id. eq_dec y x. hyp. refl.
  Qed.

(****************************************************************************)
(** ** Inversion lemma for alpha-equivalence on a lambda. *)

  Lemma lam_aeq_r : forall t x u, t ~~ Lam x u -> exists y v,
    t = Lam y v /\ v ~~ rename x y u /\ (x = y \/ ~In y (fv u)).

  Proof.
    cut (forall t t', t ~~ t' -> forall x u, t = Lam x u \/ t' = Lam x u ->
      exists y v, v ~~ rename x y u /\ (x=y \/ ~In y (fv u))
        /\ (t = Lam x u -> t' = Lam y v) /\ (t' = Lam x u -> t = Lam y v)).
    intros h t x u e. assert (p : t = Lam x u \/  Lam x u = Lam x u).
    auto. destruct (h _ _ e _ _ p) as [y [v i]]. ex y v. tauto.
    induction 1; intros z a e.
    (* refl *)
    ex z a. split. rewrite rename_id. refl. tauto.
    (* sym *)
    rewrite or_sym in e. destruct (IHaeq _ _ e) as [y [w i]]. ex y w. tauto.
    (* trans *)
    destruct e as [e|e].

    assert (p : u = Lam z a \/ v = Lam z a). auto.
    destruct (IHaeq1 _ _ p) as [x [b [i1 [i2 [i3 i4]]]]].
    assert (q : v = Lam x b \/ w = Lam x b). tauto.
    destruct (IHaeq2 _ _ q) as [y [c [j1 [j2 [j3 j4]]]]].
    ex y c. repeat split.

    rewrite j1, i1. apply rename2. hyp.

    destruct i2; destruct j2.
    left. trans x; auto.
    right. rewrite H1, rename_id in i1. rewrite <- i1. hyp.
    right. rewrite <- H2. hyp.
    eq_dec z y. auto. right. intro hy. apply H2.
    rewrite i1, fv_rename; unfold replace.
    destruct (mem z (fv a)); set_iff; auto.

    tauto. intro hw. subst u w. tauto.

    assert (p : v = Lam z a \/ w = Lam z a). auto.
    destruct (IHaeq2 _ _ p) as [x [b [i1 [i2 [i3 i4]]]]].
    assert (q : u = Lam x b \/ v = Lam x b). tauto.
    destruct (IHaeq1 _ _ q) as [y [c [j1 [j2 [j3 j4]]]]].
    ex y c. repeat split.

    rewrite j1, i1. apply rename2. hyp.

    destruct i2; destruct j2.
    left. trans x; auto.
    right. rewrite H1, rename_id in i1. rewrite <- i1. hyp.
    right. rewrite <- H2. hyp.
    eq_dec z y. auto. right. intro hy. apply H2.
    rewrite i1, fv_rename; unfold replace.
    destruct (mem z (fv a)); set_iff; auto.

    intro hu. subst u w. tauto. tauto.
    (* app_l *)
    destruct e; discr.
    (* app_r *)
    destruct e; discr.
    (* lam *)
    destruct e as [e|e]; inversion e; subst.
    ex z u'. rewrite rename_id. intuition.
    ex z u. rewrite rename_id. intuition.
    (* alpha *)
    destruct e as [e|e].
    inversion e. subst. ex y (rename z y a). split_all. refl.
    inversion e. subst. ex x u. rewrite rename2, rename_id. 2: auto.
    split_all. refl. rewrite fv_rename; unfold replace.
    case_eq (mem x (fv u));
      [rewrite <- mem_iff|rewrite <- not_mem_iff]; intro hx.
    right. set_iff. intros [h|h]. subst z. tauto. tauto.
    auto.
  Qed.

  Lemma lam_aeq_l : forall t x u, Lam x u ~~ t -> exists y v,
    t = Lam y v /\ v ~~ rename x y u /\ (x = y \/ ~In y (fv u)).

  Proof. intros t x u h. apply lam_aeq_r. sym. hyp. Qed.

  Lemma permut_rename v x y u :
    v ~~ rename x y u -> (x = y \/ ~In y (fv u)) ->
    u ~~ rename y x v /\ (x = y \/ ~In x (fv v)).

  Proof.
    intros e h. split.
    rewrite e, rename2, rename_id. refl. hyp.
    rewrite e, fv_rename; unfold replace. destruct h. auto.
    subst. auto.
    case_eq (mem x (fv u)); intro i.
    2:{ rewrite <- not_mem_iff in i. auto. }
    right. set_iff. rewrite <- mem_iff in i. split_all. subst. contr.
  Qed.

  Arguments permut_rename [v x y u] _ _.

  Ltac permut_rename h :=
    apply permut_rename in h;
    [ let h1 := fresh "i" in let h2 := fresh "i" in destruct h as [h1 h2]
    | try tauto].

(****************************************************************************)
(** Inversion tactic for alpha-equivalence. *)

  Ltac inv_aeq_0 h :=
    let u1 := fresh "u" in let u2 := fresh "u" in let x := fresh "x" in
      let i1 := fresh "i" in let i2 := fresh "i" in let i3 := fresh "i" in
        match type of h with
          | Var _ ~~ _ => apply var_aeq_l in h
          | _ ~~ Var _ => apply var_aeq_r in h
          | Fun _ ~~ _ => apply fun_aeq_l in h
          | _ ~~ Fun _ => apply fun_aeq_r in h
          | App _ _ ~~ _ => destruct (app_aeq_l h) as [u1 [u2 [i1 [i2 i3]]]]
          | _ ~~ App _ _ => destruct (app_aeq_r h) as [u1 [u2 [i1 [i2 i3]]]]
          | Lam _ _ ~~ _ => destruct (lam_aeq_l h) as [x [u1 [i1 [i2 i3]]]]
          | _ ~~ Lam _ _ => destruct (lam_aeq_r h) as [x [u1 [i1 [i2 i3]]]]
        end; simpl_aeq.

(****************************************************************************)
(** Compatibility of some basic predicates/functions with [aeq]. *)

  Global Instance not_lam_aeq : Proper (aeq ==> impl) not_lam.

  Proof.
    intros u v uv hu x a hv. subst.
    inv_aeq_0 uv; clear uv; subst. eapply hu. refl.
  Qed.

  Global Instance head_aeq : Proper (aeq ==> aeq) head.

  Proof.
    intros u v uv. revert u v uv.
    induction u; intros v uv; inv_aeq_0 uv; subst; simpl.
    refl. refl. firstorder auto with crelations. fo.
  Qed.

(****************************************************************************)
(** ** Properties of [clos_aeq]. *)

  Lemma clos_aeq_intro_refl (R : rel Te) t u : R t u -> clos_aeq R t u.

  Proof. intro tu. eapply clos_aeq_intro. refl. refl. hyp. Qed.

  Arguments clos_aeq_intro_refl [R t u] _ : rename.

  Lemma clos_aeq_inv R t u :
    clos_aeq R t u -> exists t' u', t ~~ t' /\ u ~~ u' /\ R t' u'.

  Proof. intro tu. inversion tu; clear tu; subst. ex u' v'. intuition. Qed.

  Lemma clos_aeq_eq R : clos_aeq R == aeq @ (R @ aeq).

  Proof.
    split.
    (* << *)
    intros t u tu.
    destruct (clos_aeq_inv tu) as [t' [u' [tt' [uu' t'u']]]]; clear tu.
    ex t'. intuition. ex u'. intuition.
    (* >> *)
    intros t u [t' [tt' [u' [t'u' u'u]]]]. eapply clos_aeq_intro.
    apply tt'. sym. apply u'u. hyp.
  Qed.

  Lemma incl_clos_aeq R : R << clos_aeq R.

  Proof.
    intros u v uv. apply clos_aeq_intro with (u':=u) (v':=v).
    refl. refl. hyp.
  Qed.

  (** Alpha-closure is compatible with relation inclusion/equivalence. *)

  Global Instance clos_aeq_incl : Proper (inclusion ==> inclusion) clos_aeq.

  Proof.
    intros R S RS u v uv. inversion uv; subst.
    apply clos_aeq_intro with (u':=u') (v':=v'); fo.
  Qed.

  Global Instance clos_aeq_same : Proper (same ==> same) clos_aeq.

  Proof. intros R S [RS SR]. split. rewrite RS. refl. rewrite SR. refl. Qed.

  (** Alpha-closure distributes overs union. *)

  Lemma clos_aeq_union : forall R S,
    clos_aeq (R U S) == clos_aeq R U clos_aeq S.

  Proof.
    intros R S. split.
    (* << *)
    induction 1.
    destruct H1 as [h|h]; [left|right];
      (eapply clos_aeq_intro; [apply H | apply H0 | hyp]).
    (* >> *)
    intros t u [h|h]. eapply clos_aeq_incl. apply incl_union_l. refl. hyp.
    eapply clos_aeq_incl. apply incl_union_r. refl. hyp.
  Qed.

  (** Alpha-closure is compatible with alpha-equivalence. *)

  Global Instance clos_aeq_aeq R : Proper (aeq ==> aeq ==> impl) (clos_aeq R).

  Proof.
    intros u u' uu' v v' vv' h. inversion h; subst.
    eapply clos_aeq_intro.
    trans u. hyp. apply H.
    trans v. hyp. apply H0.
    hyp.
  Qed.

  (** Alpha-closure preserves monotony. *)

  Global Instance clos_aeq_mon R : Monotone R -> Monotone (clos_aeq R).

  Proof.
    intro h. split.
    (* app_l *)
    intros u v uv w w' ww'. inversion uv; subst.
    apply clos_aeq_intro with (u':=App u' w') (v':=App v' w').
    rewrite H. refl. rewrite H0. refl. mon.
    (* app_r *)
    intros w w' ww' u v uv. inversion uv; subst.
    apply clos_aeq_intro with (u':=App w' u') (v':=App w' v').
    rewrite H. refl. rewrite H0. refl. mon.
    (* lam *)
    intros x x' xx' u v uv. inversion uv; subst.
    apply clos_aeq_intro with (u':=Lam x' u') (v':=Lam x' v').
    rewrite H. refl. rewrite H0. refl. mon.
  Qed.

  (** [clos_mon (clos_aeq R)] is included in [clos_aeq (clos_mon R)]. *)

  Lemma clos_mon_aeq_incl R : clos_mon (clos_aeq R) << clos_aeq (clos_mon R).

  Proof.
    apply clos_mon_min. apply clos_aeq_mon. apply monotone_clos_mon.
    apply clos_aeq_incl. intros u v uv. apply m_step. hyp.
  Qed.

  (** Alpha-closure preserves stability by substitution. *)

  Global Instance subs_clos_aeq R : Proper (Logic.eq ==> R ==> clos_aeq R) subs ->
    Proper (Logic.eq ==> clos_aeq R ==> clos_aeq R) subs.

  Proof.
    intros h s s' ss' u u' uu'. subst s'. inversion uu'; clear uu'; subst.
    rewrite H, H0. apply h. refl. hyp.
  Qed.

  (* Note that the previous lemma cannot be used to prove the
  following one since [clos_subs R] is NOT stable by substitution
  since substitution composition is correct modulo alpha-equivalence
  only. *)

  Global Instance subs_clos_aeq_subs R :
    Proper
      (Logic.eq ==> clos_aeq (clos_subs R) ==> clos_aeq (clos_subs R)) subs.

  Proof.
    intros s s' ss' t u tu. subst s'.
    inversion tu; inversion H1; subst; clear tu H1.
    (*VERY SLOW*)rewrite H0, H, 2!subs_comp.
    apply clos_aeq_intro_refl. apply subs_step. hyp.
  Qed.

  (** [clos_aeq o clos_mon] preserves stability by substitution. *)

  Global Instance subs_clos_aeq_mon R : Proper (Logic.eq ==> R ==> clos_aeq R) subs ->
    Proper (Logic.eq ==> clos_aeq (clos_mon R) ==> clos_aeq (clos_mon R)) subs.

  Proof.
    intros h s s' ss' u v uv. subst s'. revert u v uv s.
    (* We proceed by induction on the size of [u]. *)
    intro u; pattern u; apply (induction_ltof1 size); clear u.
    intros u IH v uv s. inversion uv; clear uv; subst. rewrite H, H0.
    (* We now proceed by case on [clos_mon R u' v']. *)
    inversion H1; clear H1; subst.
    (* top *)
    apply clos_mon_aeq_incl. apply m_step. apply h. refl. hyp.
    (* app_l *)
    simpl. mon. apply IH. unfold ltof. rewrite H. simpl. max.
    apply incl_clos_aeq. hyp.
    (* app_r *)
    simpl. mon. apply IH. unfold ltof. rewrite H. simpl. max.
    apply incl_clos_aeq. hyp.
    (* lam *)
    (* We rename [x] into some variable [k] not in [xs] so that [subs s]
       makes no alpha-conversion. *)
    set (xs := union (union (fv u0) (fvcodom (remove x (fv u0)) s))
                     (union (fv u'0) (fvcodom (remove x (fv u'0)) s))).
    set (k := var_notin xs).
    gen (var_notin_ok xs). fold k. unfold xs. set_iff. intro hk.
    rewrite (aeq_alpha k). 2: tauto. rewrite (@aeq_alpha x _ k). 2: tauto.
    rewrite subs_lam_no_alpha. 2: rewrite remove_fv_rename; tauto.
    rewrite subs_lam_no_alpha. 2: rewrite remove_fv_rename; tauto.
    mon. apply IH. unfold ltof. rewrite size_rename, H. simpl. lia.
    apply IH. unfold ltof. rewrite H. simpl. lia.
    apply incl_clos_aeq. hyp.
  Qed.

  (** Alpha-closure preserves free variables. *)

  Global Instance fv_clos_aeq : forall R,
    Proper (R --> Subset) fv -> Proper (clos_aeq R --> Subset) fv.

  Proof.
    intros R fv_R t u tu. inversion tu; subst; clear tu.
    rewrite H, H0, <- H1. refl.
  Qed.

  Lemma fv_R_notin_fv_lam : forall R x y u v, Proper (R --> Subset) fv ->
    R (Lam x u) (Lam y v) -> y=x \/ ~In x (fv v).

  Proof.
    intros R x y u v fv_R r. rewrite notin_fv_lam, <- r. simpl. set_iff. fo.
  Qed.

  Arguments fv_R_notin_fv_lam [R x y u v] _ _.

  (** Alpha-closure preserves termination of size-decreasing relations. *)

  Lemma clos_aeq_wf_size : forall R, R << transp (ltof size) -> WF (clos_aeq R).

  Proof.
    intros R h. apply (WF_incl (transp (ltof size))).
    2: apply transp_ltof_wf.
    intros t u tu. inversion tu; clear tu; subst. unfold transp, ltof.
    rewrite H, H0. apply h. hyp.
  Qed.

(****************************************************************************)
(** ** Compatibility of [apps] with [aeq] and [vaeq]. *)

  Global Instance apps_aeq : forall n, Proper (aeq ==> vaeq ==> aeq) (@apps n).

  Proof.
    intros n t t' tt' us us' usus'. revert n us us' usus' t t' tt'.
    induction us; simpl; intros us' usus' t t' tt'.
    VOtac. simpl. hyp.
    VSntac us'. simpl. rewrite H in usus'. destruct usus' as [h1 h2].
    apply IHus. hyp. rewrite tt', h1. refl.
  Qed.

  Lemma apps_aeq_r : forall n (vs : Tes n) v t, t ~~ apps v vs ->
    exists u us, t = apps u us /\ u ~~ v /\ vaeq us vs.

  Proof.
    induction vs; simpl; intros v t a.
    (* nil *)
    ex t (@Vnil Te). simpl. intuition.
    (* cons *)
    rename h into w. destruct (IHvs _ _ a) as [u [us [h1 [h2 h3]]]].
    inv_aeq_0 h2; clear h2; subst. ex u0 (Vcons u1 us). simpl.
    rewrite Vforall2_cons_eq. intuition.
  Qed.

  Arguments apps_aeq_r [n vs v t0] _ : rename.

  Lemma apps_aeq_l : forall n (vs : Tes n) v t, apps v vs ~~ t ->
    exists u us, t = apps u us /\ u ~~ v /\ vaeq us vs.

  Proof. intros n vs v t e. apply apps_aeq_r. hyp. Qed.

  Arguments apps_aeq_l [n vs v t0] _ : rename.

(****************************************************************************)
(** Extended inversion tactic for alpha-equivalence. *)

  Ltac inv_aeq h :=
    let u := fresh "u" in let us := fresh "us" in
      let i1 := fresh "i" in let i2 := fresh "i" in let i3 := fresh "i" in
        match type of h with
          | apps _ _ ~~ _ => destruct (apps_aeq_l h) as [u [us [i1 [i2 i3]]]]
          | _ ~~ apps _ _ => destruct (apps_aeq_r h) as [u [us [i1 [i2 i3]]]]
        end || inv_aeq_0 h; simpl_aeq.

(****************************************************************************)
(** ** Properties of [clos_trans_aeq]. *)

  Section atc_props.

    Variable S : relation Te.

    (** [S*] is a quasi-ordering. *)

    Global Instance atc_preorder : PreOrder (S*).

    Proof.
      split.
      intro x. apply at_aeq. refl.
      intros x y z xy yz. apply at_trans with y; hyp.
    Qed.

    (** [S*] is compatible with alpha-equivalence if [S] so is. *)

    Section aeq.

      Variable S_aeq : Proper (aeq ==> aeq ==> impl) S.

      Global Instance atc_aeq : Proper (aeq ==> aeq ==> impl) (S*).

      Proof.
        intros x x' xx' y y' yy' h. revert x y h x' xx' y' yy'.
        induction 1; intros x' xx' y' yy'.
        apply at_step. rewrite <- xx', <- yy'. hyp.
        apply at_aeq. rewrite <- xx', <- yy'. hyp.
        trans v. apply IHh1. hyp. refl. apply IHh2. refl. hyp.
      Qed.

      (*COQ: if removed, Coq fails in LComp*)
      Global Instance atc_aeq_iff : Proper (aeq ==> aeq ==> iff) (S*).

      Proof.
        intros x x' xx' y y' yy'. split; intro h; eapply atc_aeq.
        apply xx'. apply yy'. hyp. sym. apply xx'. sym. apply yy'. hyp.
      Qed.

      (** Inversion lemma for [clos_aeq_trans]. *)

      Lemma clos_aeq_trans_inv : forall t u,
        S* t u -> t ~~ u \/ exists v, S t v /\ S* v u.

      Proof.
        induction 1. firstorder auto with crelations. fo. destruct IHclos_aeq_trans1 as [h|[t [h1 h2]]].
        destruct IHclos_aeq_trans2 as [i|[t' [i1 i2]]].
        left. trans v; hyp.
        right. ex t'. rewrite h. auto.
        right. ex t. split. hyp. trans v; hyp.
      Qed.

    End aeq.

    (** [S*] is stable by substitution if [S] so is. *)

    Section subs.

      Variable subs_S : Proper (Logic.eq ==> S ==> S) subs.

      Global Instance subs_atc : Proper (Logic.eq ==> S* ==> S*) subs.

      Proof.
        intros s s' ss' x y xy. subst s'. revert x y xy. induction 1.
        apply at_step. apply subs_S; auto.
        apply at_aeq. rewrite H. refl.
        trans (subs s v); hyp.
      Qed.

(*REMOVE?*)
      Global Instance rename_atc :
        Proper (Logic.eq ==> Logic.eq ==> S* ==> S*) rename.

      Proof.
        intros x x' xx' y y' yy' u u' uu'. unfold Def.rename.
        rewrite xx', yy', uu'. refl.
      Qed.

    End subs.

    (** [S*] preserves free variables if [S] so does. *)

    Global Instance fv_atc :
      Proper (S --> Subset) fv -> Proper (S* --> Subset) fv.

    Proof.
      intros fv_S v u uv. revert u v uv. induction 1.
      apply fv_S. hyp. rewrite H. refl. trans (fv v); hyp.
    Qed.

    (** [S*] is monotone if [S] so is. *)

    Global Instance mon_atc : Monotone S -> Monotone (clos_aeq_trans S).
      (*COQ does not recognize [S*] as [clos_aeq_trans S]*)

    Proof.
      intro h. split.
      (* app_l *)
      intros u u' uu' v v' vv'. subst v'. revert u u' uu'. induction 1.
      apply at_step. mon. apply at_aeq. mon. trans (App v0 v); hyp.
      (* app_r *)
      intros u u' uu' v v' vv'. subst u'. revert v v' vv'. induction 1.
      apply at_step. mon. apply at_aeq. mon. trans (App u v); hyp.
      (* lam *)
      intros x x' xx' u u' uu'. subst x'. revert u u' uu'. induction 1.
      apply at_step. mon. apply at_aeq. mon. trans (Lam x v); hyp.
    Qed.

    Global Instance App_atc : Monotone S -> Proper (S* ==> S* ==> S*) App.

    Proof.
      intros m u u' uu' v v' vv'. trans (App u' v).
      (* app_l *)
      clear v' vv'. revert u u' uu'. induction 1.
      apply at_step. mon. apply at_aeq. mon. trans (App v0 v); hyp.
      (* app_r *)
      clear u uu'. revert v v' vv'. induction 1.
      apply at_step. mon. apply at_aeq. mon. trans (App u' v); hyp.
    Qed.

    Global Instance Lam_atc : Monotone S -> Proper (Logic.eq ==> S* ==> S*) Lam.

    Proof.
      intros m x x' xx' u u' uu'. subst x'. revert u u' uu'. induction 1.
      apply at_step. mon. apply at_aeq. mon. trans (Lam x v); hyp.
    Qed.

    (** A predicate is stable by [S*] if it is stable by [~~] and [S]. *)

    Global Instance proper_atc P : Proper (aeq ==> impl) P ->
      Proper (S ==> impl) P -> Proper (S* ==> impl) P.

    Proof.
      intros P_aeq P_S_aeq u v uv hu; revert u v uv hu. induction 1; intro hu.
      rewrite <- H. hyp.
      rewrite <- H. hyp.
      tauto.
    Qed.

  End atc_props.

(*FIXME: some properties are similar to clos_aeq => factorize?*)
(****************************************************************************)
(** ** Properties of [clos_vaeq]. *)

  Section clos_vaeq.

    Variable R : relation Te.
    Infix "->R" := R (at level 70).

    Notation R_aeq := (clos_aeq R) (only parsing).
    Infix "=>R" := (clos_aeq R) (at level 70).

    Infix "==>R" := (clos_vaeq R) (at level 70).

    Lemma clos_vaeq_cons : forall u v n (us vs : Tes n),
      Vcons u us ==>R Vcons v vs
      <-> (u =>R v /\ us ~~~ vs) \/ (u ~~ v /\ us ==>R vs).

    Proof.
      intros u v n us vs. split.

      intros [x [uusx [y [xy yvvs]]]]. revert uusx yvvs xy. VSntac x. VSntac y.
      rewrite !Vforall2_cons_eq. intros [h1 h2] [i1 i2] h. inversion h.
      left. subst x0 y0 x'. (*VERY SLOW*)rewrite h1, <- i1, h2, H5, i2. split.
      apply incl_clos_aeq. hyp. refl.
      right. subst x0 y0 y'. rewrite h1, H4, i1. split. refl.
      ex (Vtail x). intuition. ex (Vtail y). intuition.

      intros [[h1 h2]|[h1 h2]].
      inversion h1; subst. ex (Vcons u' us). split.
      rewrite Vforall2_cons_eq. intuition. ex (Vcons v' us). split.
      apply Vrel1_cons_intro. auto. rewrite Vforall2_cons_eq. intuition.

      destruct h2 as [us' [usus' [vs' [us'vs' vs'vs]]]].
      ex (Vcons v us'). rewrite Vforall2_cons_eq. intuition.
      ex (Vcons v vs'). rewrite Vforall2_cons_eq. intuition.
      apply Vrel1_cons_intro. right. intuition.
    Qed.

    (** [clos_vaeq] is compatible with [vaeq]. *)

    Global Instance clos_vaeq_vaeq n :
      Proper (vaeq ==> vaeq ==> impl) (clos_vaeq (n:=n) R).

    Proof.
      intros us us' usus' ws ws' wsws' [vs [usvs [xs [bvsxs xsws]]]].
      ex vs. split. trans us; hyp. ex xs. intuition. trans ws; hyp.
    Qed.

    Lemma clos_vaeq_sub : forall n (us vs : Tes n) p q (h : p+q<=n),
      us ==>R vs -> Vsub us h ~~~ Vsub vs h \/ Vsub us h ==>R Vsub vs h.

    Proof.
      intros n us vs p q h [us' [usus' [vs' [r vsvs']]]]; symmetry in vsvs'.
      destruct (Vrel1_sub h r).
      left. rewrite (Vforall2_sub h usus'), (Vforall2_sub h vsvs'), H.
      refl.
      right. ex (Vsub us' h). split. apply Vforall2_sub. hyp.
      ex (Vsub vs' h). split. hyp. apply Vforall2_sub. hyp.
    Qed.

    Arguments clos_vaeq_sub [n us vs p q] _ _.

    (** A vector of terms is strongly normalizing for [clos_vaeq] if
    every component is strongly normalizing for [R_aeq]. *)

    Lemma sn_clos_vaeq_intro : forall n (us : Tes n),
      Vforall (SN R_aeq) us -> SN (clos_vaeq R) us.

    Proof.
      intros n x hx.
      (* We have [SN (Vrel1 R_aeq) x] since [Vforall (SN R_aeq) x]. *)
      cut (SN (Vrel1 R_aeq) x). 2: apply Vforall_SN_rel1; hyp.
      (* We can therefore proceed by well-founded induction on
      [Vrel1 R_aeq]. *)
      induction 1. apply SN_intro. intros y [x' [xx' [y' [x'y' y'y]]]].
      (* We have [x' = Vcast (Vapp x'i (Vcons a' x'j)) k0],
      [y' = Vcast (Vapp x'i (Vcons b' x'j)) k0] and [a' ->b b']. *)
      destruct (Vrel1_app_impl x'y')
        as [i [x'i [a' [j [x'j [k0 [b' [ex' [ey' a'b']]]]]]]]].
      (* Since [x ~~~ x'], we have [x = Vast (Vapp xi (Vcons a xj)) k0]. *)
      gen (Vbreak_eq_app_cast k0 x). set (k0' := Logic.eq_sym k0).
      set (p := Vbreak (Vcast x k0')). gen (VSn_eq (snd p)). intro e. rewrite e.
      set (xi := fst p). set (a := Vhead (snd p)). set (xj := Vtail (snd p)).
      intro ex. clear e.
      (* Since [y' ~~~ y], we have [y = Vast (Vapp yi (Vcons b yj)) k0]. *)
      gen (Vbreak_eq_app_cast k0 y). fold k0'.
      set (q := Vbreak (Vcast y k0')). gen (VSn_eq (snd q)). intro e. rewrite e.
      set (yi := fst q). set (b := Vhead (snd q)). set (yj := Vtail (snd q)).
      intro ey. clear e.
      (* We have i < n *)
      assert (l : i<n). lia.
      (* We now prove that [a ~~ a']. *)
      assert (aa' : a ~~ a').
      assert (s1 : a = Vnth x l). rewrite ex, Vnth_cast, Vnth_app.
      destruct (Compare_dec.le_gt_dec i i). 2: lia.
      rewrite Vnth_cons_head. refl. lia.
      assert (s2 : a' = Vnth x' l). rewrite ex', Vnth_cast, Vnth_app.
      destruct (Compare_dec.le_gt_dec i i). 2: lia.
      rewrite Vnth_cons_head. refl. lia.
      rewrite s1, s2. apply Vforall2_elim_nth. hyp.
      (* We now prove that [b ~~ b']. *)
      assert (bb' : b ~~ b').
      assert (t1 : b = Vnth y l). rewrite ey, Vnth_cast, Vnth_app.
      destruct (Compare_dec.le_gt_dec i i). 2: lia.
      rewrite Vnth_cons_head. refl. lia.
      assert (t2 : b' = Vnth y' l). rewrite ey', Vnth_cast, Vnth_app.
      destruct (Compare_dec.le_gt_dec i i). 2: lia.
      rewrite Vnth_cons_head. refl. lia.
      rewrite t1, t2. apply Vforall2_elim_nth. hyp.
      (* We now prove that [y ~~~ Vcast (Vapp xi (Vcons b xj)) k0]. *)
      assert (h :  y ~~~ Vcast (Vapp xi (Vcons b xj)) k0).
      rewrite ex, ex', Vforall2_cast in xx'.
      rewrite ey, ey', Vforall2_cast in y'y.
      trans (Vcast (Vapp x'i (Vcons b x'j)) k0).
      (* left *)
      apply Vforall2_intro_nth. intros k hk.
      rewrite ey, 2!Vnth_cast, 2!Vnth_app.
      destruct (Compare_dec.le_gt_dec i k).
      rewrite 2!Vnth_cons. destruct (NatUtil.lt_ge_dec 0 (k-i)). 2: refl.
      apply Vforall2_elim_nth. eapply Vforall2_cons_elim.
      eapply Vforall2_app_elim_r. sym. apply y'y.
      apply Vforall2_elim_nth. eapply Vforall2_app_elim_l. sym. apply y'y.
      (* right *)
      apply Vforall2_intro_nth. intros k hk. rewrite 2!Vnth_cast, 2!Vnth_app.
      destruct (Compare_dec.le_gt_dec i k).
      rewrite 2!Vnth_cons. destruct (NatUtil.lt_ge_dec 0 (k-i)). 2: refl.
      apply Vforall2_elim_nth. eapply Vforall2_cons_elim.
      eapply Vforall2_app_elim_r. sym. apply xx'.
      apply Vforall2_elim_nth. eapply Vforall2_app_elim_l. sym. apply xx'.
      (* We now prove that
      [Vrel1 R_aeq x (Vcast (Vapp xi (Vcons b xj)) k0)]. *)
      assert (r : Vrel1 R_aeq x (Vcast (Vapp xi (Vcons b xj)) k0)).
      rewrite ex. apply Vrel1_cast_intro. apply Vrel1_app_intro_l.
      apply Vrel1_cons_intro.
      left. rewrite aa', bb'. intuition. apply incl_clos_aeq. hyp.
      (* We can now end the proof. *)
      rewrite h. apply H0. hyp. apply SN_rel1_forall. apply H. hyp.
    Qed.

    Lemma sn_clos_vaeq_elim : forall n i (hi : i<n) (us : Tes n),
      SN (clos_vaeq R) us -> SN R_aeq (Vnth us hi).

    Proof.
      intros n i hi us hus. elim hus; clear us hus. intros us h1 h2.
      apply SN_intro. intros ui' uiui'.
      destruct (clos_aeq_inv uiui') as [vi [vi' [uivi [ui'vi' vivi']]]];
        clear uiui'. rewrite <- (Vnth_replace hi hi us). apply h2.

      ex (Vreplace us hi vi). split.
      apply Vforall2_intro_nth. intros j jn. destruct (eq_nat_dec j i).
      subst j. rewrite Vnth_replace. rewrite (Vnth_eq _ jn hi); auto.
      rewrite Vnth_replace_neq. refl. lia.

      ex (Vreplace us hi vi'). split.
      rewrite Vrel1_nth_iff. ex i hi. split.
      rewrite !Vnth_replace. hyp.
      intros j jn jni. rewrite !Vnth_replace_neq; auto.

      apply Vforall2_intro_nth. intros j jn. destruct (eq_nat_dec j i).
      subst j. rewrite !Vnth_replace. hyp.
      rewrite !Vnth_replace_neq; auto. refl.
    Qed.

  End clos_vaeq.

  (** [clos_vaeq] is compatible with [inclusion] and [same]. *)

  Global Instance clos_vaeq_incl n : Proper (incl ==> incl) (@clos_vaeq n).

  Proof. intros R R' RR'. unfold Def.clos_vaeq. rewrite RR'. refl. Qed.

  Global Instance clos_vaeq_same n : Proper (same ==> same) (@clos_vaeq n).

  Proof. intros R R' RR'. unfold Def.clos_vaeq. rewrite RR'. refl. Qed.

  (** [clos_vaeq] distributes over [union]. *)

  Lemma clos_vaeq_union n R S :
    @clos_vaeq n (R U S) == @clos_vaeq n R U @clos_vaeq n S.

  Proof.
    unfold Def.clos_vaeq. rewrite Vrel1_union, comp_union_l, comp_union_r. refl.
  Qed.

End Make.


(***************************************************************************
* Tactics to Automate Reasoning about Freshness                            *
* Brian Aydemir & Arthur Charguéraud, July 2007, Coq v8.1                  *
***************************************************************************)

Set Implicit Arguments.
Require Import Lib_Tactic List Metatheory_Var.

Ltac fresh_simpl_to_notin_in_context :=
  repeat (match goal with H: fresh _ _ _ |- _ =>
    progress (simpl in H; destruct H) end).

(* ********************************************************************** *)
(** ** Tactics for notin *)

(** For efficiency, we avoid rewrites by splitting equivalence. *)

Lemma notin_singleton_r : forall x y,
  x \notin {{y}} -> x <> y.
intros. rewrite* <- notin_singleton.
Qed.

Lemma notin_singleton_l : forall x y,
  x <> y -> x \notin {{y}}.
intros. rewrite* notin_singleton.
Qed.

Lemma notin_singleton_swap : forall x y,
  x \notin {{y}} -> y \notin {{x}}.
intros. apply notin_singleton_l.
apply sym_not_eq. apply* notin_singleton_r.
Qed.

Lemma notin_union_r : forall x E F,
  x \notin (E \u F) -> (x \notin E) /\ (x \notin F).
intros. rewrite* <- notin_union.
Qed.

Lemma notin_union_l : forall x E F,
  x \notin E -> x \notin F -> x \notin (E \u F).
intros. rewrite* notin_union.
Qed.

(** Tactics to deal with notin. It interacts with union
    singleton and empty, but not inclusion. *)

Ltac notin_solve_from x E H :=
  match type of H with x \notin ?L =>
    match L with context[E] =>
      match L with
      | E => exact H
      | ?F \u ?G =>
        let P := constr:(@notin_union_r x F G H) in
        let PF := eval simpl in (proj1 P) in
        let PG := eval simpl in (proj2 P) in
        solve [ notin_solve_from x E PF
              | notin_solve_from x E PG ]
      end
    end
  end.

Ltac notin_solve_from_context x E :=
  match goal with H: x \notin _ |- _ =>
    notin_solve_from x E H end.

Ltac notin_solve_one :=
  match goal with
  | |- _ \notin {} =>
    apply notin_empty
  | |- ?x \notin {{?y}} => (* by x <> y or y <> x *)
    apply notin_singleton_l; solve
    [ assumption | apply sym_not_eq; assumption ]
  | |- ?x \notin {{?y}} => (* by y \notin {{x}} *)
    apply notin_singleton_swap; notin_solve_from_context y ({{x}})
  | |- ?x \notin ?E  =>    (* default search *)
    notin_solve_from_context x E
  end.

Ltac notin_simpl :=
  try match goal with |- _ \notin (_ \u _) =>
    apply notin_union_l; notin_simpl end.

Ltac notin_simpl_hyps := (* forward-chaining *)
  try match goal with
  | H: _ \notin {} |- _ =>
     clear H; notin_simpl_hyps
  | H: ?x \notin {{?y}} |- _ =>
     puts (@notin_singleton_r x y H);
     clear H; notin_simpl_hyps
   | H: ?x \notin (?E \u ?F) |- _ =>
     let H1 := fresh "Fr" in let H2 := fresh "Fr" in
     destruct (@notin_union_r x E F H) as [H1 H2];
     clear H; notin_simpl_hyps
  end.

Ltac notin_simpls :=
  notin_simpl_hyps; notin_simpl.

Ltac notin_solve :=
  fresh_simpl_to_notin_in_context;
  notin_simpl; notin_solve_one.

Ltac notin_contradiction :=
  match goal with H: ?x \notin ?E |- _ =>
    match E with context[x] =>
      let K := fresh in assert (K : x \notin {{x}});
        [ notin_solve_one
        | contradictions; apply (notin_same K) ]
    end
  end.

Ltac notin_neq_solve :=
  apply notin_singleton_r; notin_solve.

Ltac fold_notin :=
  repeat match goal with
  | H: context [?x \in ?E -> False] |- _ =>
    fold (not (x \in E)) in H
  | |- context [?x \in ?E -> False] =>
    fold (not (x \in E)) end.

(* ********************************************************************** *)
(** Demo for notin *)

Lemma test_notin_solve_1 : forall x E F G,
  x \notin E \u F -> x \notin G -> x \notin (E \u G).
intros. notin_solve.
Qed.

Lemma test_notin_solve_2 : forall x y E F G,
  x \notin E \u {{y}} \u F -> x \notin G ->
  x \notin {{y}} /\ y \notin {{x}}.
intros. split. notin_solve. notin_solve.
Qed.

Lemma test_notin_solve_3 : forall x y,
  x <> y -> x \notin {{y}} /\ y \notin {{x}}.
intros. split. notin_solve. notin_solve.
Qed.

Lemma test_notin_contradiction : forall x y E F G,
  x \notin (E \u {{x}} \u F) -> y \notin G.
intros. notin_contradiction.
Qed.

Lemma test_neq_solve : forall x y E F,
  x \notin (E \u {{y}} \u F) -> y \notin E ->
  y <> x /\ x <> y.
intros. split. notin_neq_solve. notin_neq_solve.
Qed.

(***************************************************************************)
(** Automation: hints to solve "notin" subgoals automatically. *)

Hint Extern 1 (_ \notin _) => notin_solve : core.
Hint Extern 1 (_ \in _ -> False) => fold_notin : core.
Hint Extern 1 (_ <> _ :> var) => notin_neq_solve : core.
Hint Extern 1 (_ <> _ :> S.elt) => notin_neq_solve : core.

(* ********************************************************************** *)
(** ** Tactics for fresh *)

Hint Extern 1 (fresh _ _ _) => simpl : core.

Lemma fresh_union_r : forall xs L1 L2 n,
  fresh (L1 \u L2) n xs -> fresh L1 n xs /\ fresh L2 n xs.
Proof.
  induction xs; simpl; intros; destruct n;
  try solve [ contradictions* ]. auto.
  destruct H. splits~.
  forward* (@IHxs (L1 \u {{a}}) L2 n).
   rewrite union_comm.
   rewrite union_comm_assoc.
   rewrite* union_assoc.
  forward* (@IHxs L1 (L2 \u {{a}}) n).
   rewrite* union_assoc.
Qed.

Lemma fresh_union_l : forall xs L1 L2 n,
  fresh L1 n xs -> fresh L2 n xs -> fresh (L1 \u L2) n xs.
Proof.
  induction xs; simpl; intros; destruct n;
  try solve [ contradictions* ]. auto.
  destruct H. destruct H0. split2~.
  forward~ (@IHxs (L1 \u {{a}}) (L2 \u {{a}}) n).
  intros K.
  rewrite <- (union_same {{a}}).
  rewrite union_assoc.
  rewrite <- (@union_assoc L1).
  rewrite (@union_comm L2).
  rewrite (@union_assoc L1).
  rewrite* <- union_assoc.
Qed.

Lemma fresh_empty : forall L n xs,
  fresh L n xs -> fresh {} n xs.
Proof.
  intros. rewrite <- (@union_empty_r L) in H.
  destruct* (fresh_union_r _ _ _ _ H).
Qed.

Lemma fresh_length : forall xs L n,
  fresh L n xs -> n = length xs.
Proof.
  induction xs; simpl; intros L n Fr; destruct n;
   try solve [contradictions*]. auto.
  rewrite* <- (@IHxs (L \u {{a}}) n).
Qed.

Lemma fresh_resize : forall n xs L,
  fresh L n xs -> fresh L (length xs) xs.
Proof.
  introv Fr. rewrite* <- (fresh_length _ _ _ Fr).
Qed.

Ltac fresh_solve_from xs n E H :=
  match type of H with fresh ?L _ _ =>
    match L with context[E] =>
      match L with
      | E => exact H
      | ?F \u ?G =>
        let P := constr:(@fresh_union_r xs F G n H) in
        let PF := eval simpl in (proj1 P) in
        let PG := eval simpl in (proj2 P) in
        solve [ fresh_solve_from xs n E PF
              | fresh_solve_from xs n E PG ]
      end
    end
  end.

Ltac fresh_solve_from_context xs n E :=
  match goal with H: fresh _ n xs |- _ =>
    fresh_solve_from xs n E H end.

Ltac fresh_solve_one :=
  assumption ||
  match goal with
  | |- fresh {} ?n ?xs =>
    match goal with H: fresh ?L n xs |- _ =>
      apply (@fresh_empty L n xs H) end
  (* | H: fresh _ ?n ?xs |- fresh ?E ?n ?xs =>
    fresh_solve_from xs n E H *)
  | |- fresh _ (length ?xs) ?xs =>
    match goal with H: fresh _ ?n xs |- _ =>
      progress (apply (@fresh_resize n)); fresh_solve_one end
  end.

Ltac fresh_simpl :=
  try match goal with |- fresh (_ \u _) _ _ =>
    apply fresh_union_l; fresh_simpl end.

Ltac fresh_split :=
  match goal with
  | H: fresh (?L1 \u ?L2) ?n ?xs |- fresh _ _ ?xs =>
      destruct (fresh_union_r xs L1 L2 n H); clear H; fresh_split
  | _ => try fresh_simpl
  end.

Ltac fresh_simpl_to_notin_in_goal :=
  simpl; splits.

Ltac fresh_simpl_to_notin_solve :=
  fresh_simpl_to_notin_in_context;
  fresh_simpl_to_notin_in_goal;
  notin_solve.

Ltac fresh_solve :=
  (fresh_split; fresh_solve_one) || (fresh_simpl; fresh_simpl_to_notin_solve).

(* ********************************************************************** *)
(** Demo for notin *)

Lemma test_fresh_solve_1 : forall xs L1 L2 n,
  fresh (L1 \u L2) n xs -> fresh L1 n xs.
Proof.
  intros. fresh_solve.
Qed.

Lemma test_fresh_solve_2 : forall xs L1 L2 n,
 fresh (L1 \u L2) n xs -> fresh L2 n xs.
Proof.
  intros. fresh_solve.
Qed.

Lemma test_fresh_solve_3 : forall xs L1 L2 n,
 fresh (L1 \u L2) n xs -> fresh {} n xs.
Proof.
  intros. fresh_solve.
Qed.

Lemma test_fresh_solve_4 : forall xs L1 L2 n,
 fresh (L1 \u L2) n xs -> fresh L1 (length xs) xs.
Proof.
  intros. fresh_solve.
Qed.

(***************************************************************************)
(** Automation: hints to solve "fresh" subgoals automatically. *)

Hint Extern 1 (fresh _ _ _) => fresh_solve : core.


Set Warnings "-notation-overridden,-parsing,-deprecated-hint-without-locality".
From Coq Require Import Strings.String.  (* for manual grading *)
From Coq Require Export Bool.Bool.
From Coq Require Export Arith.Arith.
From Coq Require Export Arith.EqNat.
From Coq Require Export Lia.
From Coq Require Export Lists.List.
Export ListNotations.

Inductive tstind : nat -> Type :=
  kek (i: nat): forall (n: nat), tstind n.

Definition foo (n: nat) : tstind n := kek 0 n.

Definition bar: bool -> Type -> Type -> Type := fun b tl tr =>
  match b with
  | true => tl
  | false => tr
  end.

Definition barty (Tl Tr: Prop) : Prop := exists (b: bool), if b then Tl else Tr.

Definition inl_mysum (Tl Tr: Prop) (l: Tl) : barty Tl Tr.
Proof.
  intros.
  unfold barty.
  exists true.
  apply l.
Defined.

Print inl_mysum.

Definition sumT A B := sigT (fun (b : bool) => if b then A else B).
Definition inl_sumT A B (a: A) := @existT bool (fun (b : bool) => if b then A else B) true a.

(*Definition  barty nat bool := inl_mysum bool bool true.*)

Print ex. (* Sigma type for Prop *)
Print sigT. (* Sigma for Type *)
Print sig.

Definition foo11 : bool -> Type :=
  fun b => match b with
           | true => nat
           | false => bool
           end.

Definition bar11 : forall (b: bool) (c: foo11 b), nat := fun _ _ => 11.

Compute (bar11 false true).
Fail Compute (bar11 false 111).

Inductive Fin : nat -> Type :=
| FinItem (i: nat) : forall n, i < n -> Fin n.

Definition correctItem: Fin 2.
Proof.
  apply (FinItem 1).
  lia.
Defined.

Definition idA : forall (A: Type), A -> A :=
  fun (A: Type) (a: A) => a.

Locate "exists".

Definition even_nat := {x : nat | Nat.Even x}.

Print even_nat.

Module SigSandbox.
  Inductive sig {A : Type} (P : A -> Prop) : Type :=
  | exist (x : A) : P x -> sig P.

  Notation "{ x : A | P }" := (sig A (fun x => P x)).

  Inductive ex {A : Type} (P : A -> Prop) : Prop :=
  | ex_intro (x : A) : P x -> ex P.

  Definition proj1_sig {A : Type} {P : A -> Prop} (e : sig P) : A :=
    match e with
    | exist _ x _ => x
    end.

  Definition proj2_sig {A : Type} {P : A -> Prop} (e : sig P) : P (proj1_sig e) :=
    match e with
    | exist _ _ p => p
    end.

  Fail Definition proj1_ex {A : Type} {P : A -> Prop} (e : ex P) : A :=
    match e with
    | ex_intro _ x _ => x
    end.
End SigSandbox.

Lemma tst_tact: forall A B, A -> (A -> B) -> B.
Proof.
  intros.
  pose (pB := X0 X).
  pose proof (pB' := X0 X).
  exact pB.
Qed.

Lemma tst_tact2: forall A B, A -> (A -> B) -> B.
Proof.
  intros.
  refine (X0 _).
  exact X.
Qed.

Lemma tst_tact3: forall A B, A \/ B -> (A -> B) -> B.
Proof.
  intros.
  case H.
  - intros. refine (H0 _). exact H1.
  - intros. exact H1.
Qed.

Lemma tst_nat_comm: forall n m, n + m = m + n.
Proof.
  intros.
  elim n.
Admitted.

(*
Print list_ind.

Fixpoint my_list_ind (A: Type) (P: list A -> Prop):
  P [] ->
  (forall a, P [a]) ->
  (forall a b l, P l -> P (a :: l ++ [b])) ->
  (forall l, P l) :=
  fun Pnil Pone Pt l =>
    match l with
    | [] => Pnil
    | [a] => Pone a
    | a :: b :: nil => Pt a b nil Pnil
    | a :: b :: l => _
    end.
*)


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj15eqsynthconj2 : forall  (lv0 : natural) (lv1 : natural), (@eq natural (mult lv0 lv1) (plus Zero (mult lv1 lv0))).
Admitted.
QuickChick conj15eqsynthconj2.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

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

Theorem pipo_6 : (forall P Q A C Bprime Cprime : Universe, ((wd_ P Q /\ (wd_ P A /\ (wd_ P Bprime /\ (wd_ P Cprime /\ (wd_ A Bprime /\ (wd_ A C /\ (wd_ C Cprime /\ (wd_ C P /\ (col_ P Q A /\ (col_ P Q Bprime /\ (col_ P Q Cprime /\ col_ A A C))))))))))) -> col_ A Bprime P)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Export Iron.Language.SystemF2Cap.Type.Exp.Base.
Require Export Iron.Language.SystemF2Cap.Type.Relation.EquivT.
Require Export Iron.Language.SystemF2Cap.Type.Relation.SubsT.
Require Export Iron.Language.SystemF2Cap.Type.Relation.EquivTs.
Require Export Iron.Language.SystemF2Cap.Type.Relation.KindTs.
Require Export Iron.Language.SystemF2Cap.Type.Operator.BunchT.

(********************************************************************)
Inductive SubsTs  : kienv -> stprops -> list ty -> list ty -> ki -> Prop :=
 | SbsSum
   :  forall ke sp ts1 ts2 k
   ,  SumKind k
   -> KindTs ke sp ts1 k
   -> KindTs ke sp ts2 k
   -> Forall (fun t2 => In t2 ts1) ts2
   -> SubsTs ke sp ts1 ts2 k.

Lemma subsTs_single_cases
 :  forall ke sp ts1 t1 t2 k
 ,  SubsTs ke sp (ts1 :> t1) (nil :> t2) k
 -> SubsTs ke sp ts1 (nil :> t2) k
 \/ t1 = t2.
Proof.
 intros.
 inverts H.
 simpl in H3.
 eapply Forall_forall with (x := t2) in H3.
 - inverts H3.
   + tauto.
   + left. eapply SbsSum; snorm. eauto.
 - auto.
Qed.

Lemma subsTs_sumkind
 :  forall ke sp ts1 ts2 k
 ,  SubsTs ke sp ts1 ts2 k
 -> SumKind k.
Proof. intros. inverts H; auto. Qed.
Hint Resolve subsTs_sumkind.

Lemma subsTs_kinds_left
 :  forall ke sp ts1 ts2 k
 ,  SubsTs ke sp ts1 ts2 k
 -> KindTs ke sp ts1 k.
Proof. intros. inverts H; auto. Qed.
Hint Resolve subsTs_kinds_left.

Lemma subsTs_kinds_right
 :  forall ke sp ts1 ts2 k
 ,  SubsTs ke sp ts1 ts2 k
 -> KindTs ke sp ts1 k.
Proof. intros. inverts H; auto. Qed.
Hint Resolve subsTs_kinds_right.

Lemma subsTs_refl
 :  forall ke sp ts k
 ,  SumKind k
 -> KindTs ke sp ts k
 -> SubsTs ke sp ts ts k.
Proof.
 intros.
 eapply SbsSum; eauto.
 snorm.
Qed.
Hint Resolve subsTs_refl.

Lemma subsTs_trans
 :  forall ke sp ts1 ts2 ts3 k
 ,  SubsTs ke sp ts1 ts2 k
 -> SubsTs ke sp ts2 ts3 k
 -> SubsTs ke sp ts1 ts3 k.
Proof.
 intros.
 inverts H. inverts H0.
 eapply SbsSum; snorm.
Qed.

Lemma equivTs_subsTs
 :  forall ke sp t1 t2 k
 ,  SumKind k
 -> EquivTs ke sp t1 t2 k
 -> SubsTs  ke sp t1 t2 k.
Proof.
 intros.
 inverts H0.
 eapply SbsSum; auto.
Qed.

Lemma equivT_subsTs
 :  forall ke sp t1 t2 k
 ,  SumKind k
 -> EquivT ke sp t1 t2 k
 -> SubsTs ke sp (flattenT t1) (flattenT t2) k.
Proof.
 intros.
 eapply equivTs_subsTs; auto.
 eapply equivT_equivTs; auto.
Qed.

Lemma subsT_subsTs
 :  forall ke sp t1 t2 k
 ,  SumKind k
 -> SubsT  ke sp t1             t2           k
 -> SubsTs ke sp (flattenT t1) (flattenT t2) k.
Proof.
 intros ke sp t1 t2 k HS HT.
 induction HT.

 - Case "SbEquiv".
   eapply equivT_subsTs; auto.

 - Case "SbTrans".
   eapply subsTs_trans.
    eauto.
    spec IHHT1 HS.
    spec IHHT2 HS.
    auto.

 - Case "SbBot".
   simpl.
   eapply SbsSum; snorm.

 - Case "SbSumAbove".
   eapply SbsSum; rip.
    + have (KindT ke sp t1 k). auto.
    + simpl. eapply kindTs_app; eauto.
    + simpl. eapply Forall_app; eauto.
      inverts IHHT1; auto.
      inverts IHHT2; auto.

 - Case "SbSumBelow".
   spec IHHT HS.
   eapply SbsSum; eauto.
   inverts IHHT.
   snorm.

 - Case "SbSumAboveLeft".
   spec IHHT HS.
   simpl in IHHT.
   inverts IHHT.
   eapply SbsSum; eauto.

 - Case "SbSumAboveRight".
   spec IHHT HS.
   inverts IHHT.
   eapply SbsSum; eauto.
Qed.
Hint Resolve subsT_subsTs.

Lemma subsTs_subsT_1
 :  forall ke sp ts1 t2 k
 ,  SubsTs ke sp ts1 (t2 :: nil) k
 -> SubsT  ke sp (bunchT k ts1) t2 k.
Proof.
 intros.
 induction ts1.
 - nope.
 - have (SumKind k)        by inverts H; auto.
   have (KindT ke sp a  k) by inverts H; eauto.
   have (KindT ke sp t2 k) by inverts H; eauto.
   simpl.

   lets D: subsTs_single_cases H.
   inverts D.

   + SCase "subs".
     rip.

   + SCase "a = t2".
     eapply SbSumBelow; auto.
     eapply bunchT_kindT. auto.
      inverts H; eauto.
Qed.

Lemma subsTs_subsT
 :  forall ke sp ts1 ts2 k
 ,  SubsTs ke sp ts1 ts2 k
 -> SubsT  ke sp (bunchT k ts1) (bunchT k ts2) k.
Proof.
 intros. gen ke sp ts1.
 induction ts2; intros.
  - have (SumKind k)   by inverts H; auto.
    simpl.
    eapply SbBot; auto.
     eapply bunchT_kindT; auto.
      inverts H. norm.

  - have (SumKind k)   by inverts H; auto.
    simpl.
    eapply SbSumAbove; auto.
    + eapply subsTs_subsT_1; auto.
      inverts H.
      eapply SbsSum; rip.
       eauto. snorm.

    + eapply IHts2.
      inverts H.
      eapply SbsSum; rip.
       eauto. snorm.
Qed.
Hint Resolve subsTs_subsT.


(** Proof Reflection in Coq ; inv_lems.v ; 050128 ; Dimitri Hendriks; Coq 8.0pl1 *)

Require Export ND.

Set Implicit Arguments.

Section Inversion_Lemmata.

Variable l1 l2 : list nat.

Let P := prf l1 l2.
Let F := frm l1 l2.
Let T := trm l1.
Let Ts := trms l1.
Let C := list F.

(* The proof terms of the following lemma's are relatively large;
   it's important to keep them opaque in other proofs. *)

Lemma nohyp_inv : forall (i : nat) (p : F), ND nil (hyp _ _ i) p -> False.
Proof.
intros i p H.
inversion H.
Qed.

Lemma hypO_inv : forall (G : C) (p q : F), ND (q :: G) (hyp _ _ 0) p -> p = q.
intros G p q H.
inversion H.
reflexivity.
Qed.

Lemma hypS_inv :
 forall (G : C) (i : nat) (p q : F),
 ND (q :: G) (hyp _ _ (S i)) p -> ND G (hyp _ _ i) p.
intros G i p q H.
inversion_clear H.
exact H0.
Qed.

Lemma top_inv : forall (G : C) (p : F), ND G (top_intro _ _) p -> p = top _ _.
Proof.
intros G p H.
inversion H.
reflexivity.
Qed.

Lemma bot_inv :
 forall (G : C) (d : P) (p q : F),
 ND G (bot_elim d q) p -> p = q /\ ND G d (bot _ _).
Proof.
intros G d p q H.
inversion_clear H.
split.
reflexivity.
exact H0.
Qed.

Lemma imp_intro_inv :
 forall (G : C) (d : P) (p q : F),
 ND G (imp_intro q d) p -> exists r : F, p = imp q r /\ ND (q :: G) d r.
Proof.
intros G d p q H.
inversion_clear H.
exists q0.
split.
reflexivity.
exact H0.
Qed.

Lemma imp_elim_inv :
 forall (G : C) (d e : P) (p : F),
 ND G (imp_elim d e) p -> exists q : F, ND G d (imp q p) /\ ND G e q.
Proof.
intros G d e p H.
inversion_clear H.
exists p0.
split.
exact H0.
exact H1.
Qed.

Lemma cnj_intro_inv :
 forall (G : C) (d1 d2 : P) (p : F),
 ND G (cnj_intro d1 d2) p ->
 exists p1 : F, (exists p2 : F, p = cnj p1 p2 /\ ND G d1 p1 /\ ND G d2 p2).
Proof.
intros G d1 d2 p H.
inversion_clear H.
exists p0.
exists q.
split.
reflexivity.
split.
exact H0.
exact H1.
Qed.

Lemma cnj_elim1_inv :
 forall (G : C) (d : P) (p : F),
 ND G (cnj_elim1 d) p -> exists q : F, ND G d (cnj p q).
Proof.
intros G d p H.
inversion_clear H.
exists q.
exact H0.
Qed.

Lemma cnj_elim2_inv :
 forall (G : C) (d : P) (p : F),
 ND G (cnj_elim2 d) p -> exists q : F, ND G d (cnj q p).
Proof.
intros G d p H.
inversion_clear H.
exists p0.
exact H0.
Qed.

Lemma dsj_intro1_inv :
 forall (G : C) (d : P) (p q2 : F),
 ND G (dsj_intro1 q2 d) p -> exists q1 : F, p = dsj q1 q2 /\ ND G d q1.
Proof.
intros G d p q2 H.
inversion_clear H.
exists p0.
split.
reflexivity.
exact H0.
Qed.

Lemma dsj_intro2_inv :
 forall (G : C) (d : P) (p q1 : F),
 ND G (dsj_intro2 q1 d) p -> exists q2 : F, p = dsj q1 q2 /\ ND G d q2.
Proof.
intros G d p q1 H.
inversion_clear H.
exists q.
split.
reflexivity.
exact H0.
Qed.

Lemma dsj_elim_inv :
 forall (G : C) (d e1 e2 : P) (p : F),
 ND G (dsj_elim d e1 e2) p ->
 exists r1 : F,
   (exists r2 : F,
      ND G d (dsj r1 r2) /\ ND (r1 :: G) e1 p /\ ND (r2 :: G) e2 p).
Proof.
intros G d e1 e2 p H.
inversion_clear H.
exists p0.
exists q.
split.
exact H0.
split.
exact H1.
exact H2.
Qed.

Lemma uvq_intro_inv :
 forall (G : C) (d : P) (p : F),
 ND G (uvq_intro d) p -> exists p' : F, p = uvq p' /\ ND (lift_cxt 0 G) d p'.
Proof.
intros G d p H.
inversion_clear H.
exists p0.
split.
reflexivity.
exact H0.
Qed.

Lemma uvq_elim_inv :
 forall (G : C) (d : P) (t : T) (p : F),
 ND G (uvq_elim t d) p ->
 exists p' : F, p = subst_frm 0 p' t /\ ND G d (uvq p').
Proof.
intros G d t p H.
inversion_clear H.
exists p0.
split.
reflexivity.
exact H0.
Qed.

Lemma exq_intro_inv :
 forall (G : C) (d : P) (t : T) (p p' : F),
 ND G (exq_intro p' t d) p -> p = exq p' /\ ND G d (subst_frm 0 p' t).
Proof.
intros G d t p p' H.
inversion_clear H.
split.
reflexivity.
exact H0.
Qed.

Lemma exq_elim_inv :
 forall (G : C) (d e : P) (p : F),
 ND G (exq_elim d e) p ->
 exists q : F, ND G d (exq q) /\ ND (q :: lift_cxt 0 G) e (lift_frm 0 p).
Proof.
intros G d e p H.
inversion_clear H.
exists p0.
split.
exact H0.
exact H1.
Qed.

End Inversion_Lemmata.