(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

(* Contribution to the Coq Library   V6.3 (July 1999)                    *)

(****************************************************************************)
(*                 The Calculus of Inductive Constructions                  *)
(*                                                                          *)
(*                                Projet Coq                                *)
(*                                                                          *)
(*                     INRIA                        ENS-CNRS                *)
(*              Rocquencourt                        Lyon                    *)
(*                                                                          *)
(*                                Coq V5.10                                 *)
(*                                                                          *)
(****************************************************************************)
(*                                Shuffle.v                                 *)
(****************************************************************************)
(* G. Huet - V5.8  Nov. 1994 *)
(*    ported V5.10 June 1995 *)

Require Import Bool.
Require Import Words.
Require Import Alternate.
Require Import Opposite.
Require Import Paired.

(***********************)
(* Shuffling two words *)
(***********************)

Inductive shuffle : word -> word -> word -> Prop :=
  | shuffle_empty : shuffle empty empty empty
  | shuffle_bit_left :
      forall u v w : word,
      shuffle u v w -> forall b : bool, shuffle (bit b u) v (bit b w)
  | shuffle_bit_right :
      forall u v w : word,
      shuffle u v w -> forall b : bool, shuffle u (bit b v) (bit b w).

(***********************)
(* The shuffling lemma *)
(***********************)

Lemma Shuffling :
 forall u v w : word,
 shuffle u v w ->
 forall b : bool,
 alt b u ->
 odd u /\
 (odd v /\ (alt (negb b) v -> paired w) /\ (alt b v -> paired_bet b w) \/
  even v /\
  (alt b v -> paired_odd_l b w) /\
  (alt (negb b) v -> paired_odd_r (negb b) w)) \/
 even u /\
 (odd v /\
  (alt (negb b) v -> paired_odd_r b w) /\ (alt b v -> paired_odd_l b w) \/
  even v /\ (alt b v -> paired_rot b w) /\ (alt (negb b) v -> paired w)).
Proof.
simple induction 1; intros.
(* 0. empty case *)
right.
split; auto.
right.
split; auto.
split; intro.
apply paired_rot_empty.
apply paired_empty.
(* 1. u before v *)
elim (alt_eq b0 b u0); trivial.
elim (H1 (negb b0)); intros.
(* 1.1. *) right.
elim H3; intros.
split; auto.
elim H5; intros.
elim H6; intros.
(* 1.1.1. *) left.
elim H8; intros.
split; auto.
split; intro.
apply paired_odd_r_from_bet; auto.
apply paired_odd_l_intro; apply H9; rewrite (negb_elim b0); auto.
elim H6; intros.
elim H8; intros.
(* 1.1.2. *) right.
split; auto.
split; intro.
apply paired_rot_bit; rewrite (negb_intro b0); apply H10;
 rewrite (negb_elim b0); auto.
apply paired_odd_l_elim; auto.
(* 1.2. *) left.
elim H3; intros.
split; auto.
elim H5; intros.
(* 1.2.1. *) left.
elim H6; intros.
elim H8; intros.
split; auto.
split; intro.
apply paired_odd_l_elim; auto.
apply paired_bet_bit; apply H9; rewrite (negb_elim b0); auto.
(* 1.2.2. *) right.
elim H6; intros.
elim H8; intros.
split; auto.
split; intro.
apply paired_odd_l_intro; apply H10; rewrite (negb_elim b0); auto.
pattern b0 at 2 in |- *; rewrite (negb_intro b0).
apply paired_odd_r_from_rot; auto.
apply alt_neg_intro with b; trivial.
(* 2. v before u *)
elim (H1 b0); intros.
(* 2.1. *) left.
elim H3; intros.
split; auto.
elim H5; intros.
(* 2.1.1. *) right.
elim H6; intros.
elim H8; intros.
split; auto.
split; intro.
elim (alt_eq b0 b v0); trivial.
apply paired_odd_l_intro; apply H9; apply alt_neg_intro with b; auto.
elim (alt_eq (negb b0) b v0); trivial.
apply paired_odd_r_from_bet; rewrite (negb_elim b0); apply H10;
 apply alt_neg_elim with b; auto.
(* 2.1.2. *) left.
elim H6; intros.
elim H8; intros.
split; auto.
split; intro.
apply paired_odd_l_elim.
elim (alt_eq (negb b0) b v0); trivial.
rewrite (negb_elim b0).
apply H9.
rewrite (negb_intro b0).
apply alt_neg_intro with b; auto.
elim (alt_eq b0 b v0); trivial.
apply paired_bet_bit; apply H10; apply alt_neg_intro with b; auto.
(* 2.2. *) right.
elim H3; intros.
split; auto.
elim H5; intros.
(* 2.2.1. *) right.
elim H6; intros.
elim H8; intros.
split; auto.
split; intro.
elim (alt_eq b0 b v0); trivial.
apply paired_rot_bit; apply H9; apply alt_neg_intro with b; auto.
elim (alt_eq (negb b0) b v0); trivial.
apply paired_odd_l_elim.
rewrite (negb_elim b0); apply H10; rewrite (negb_intro b0);
 apply alt_neg_intro with b; auto.
(* 2.2.2. *) left.
elim H6; intros.
elim H8; intros.
split; auto.
split; intro.
elim (alt_eq (negb b0) b v0); trivial.
apply paired_odd_r_from_rot; apply H9; rewrite (negb_intro b0);
 apply alt_neg_intro with b; auto.
elim (alt_eq b0 b v0); trivial.
apply paired_odd_l_intro; apply H10; apply alt_neg_intro with b; auto.
trivial.
Qed.


(***************************************************************************
* Preservation and Progress for mini-ML (CBV) - Definitions                *
* Arthur Charguéraud, July 2007                                            *
***************************************************************************)

Set Implicit Arguments.
Require List.
Require Export LibLogic LibList LibLN.

(* ********************************************************************** *)
(** ** Description of types *)

(** Grammar of types. *)

Inductive typ : Set :=
  | typ_bvar  : nat -> typ
  | typ_fvar  : var -> typ
  | typ_arrow : typ -> typ -> typ
  | typ_unit  : typ
  | typ_nat   : typ
  | typ_prod  : typ -> typ -> typ
  | typ_sum   : typ -> typ -> typ
  | typ_ref   : typ -> typ.

(** [typ] is inhabited *)

Definition typ_def := typ_unit.
Instance typ_inhab : Inhab typ.
Proof. intros. apply (prove_Inhab typ_unit). Defined.

(** Computing free variables of a type.
    Needed to say that typ_exn is closed
    and that typing of store is done with ground terms *)

Fixpoint typ_fv (T : typ) {struct T} : vars :=
  match T with
  | typ_bvar i      => \{}
  | typ_fvar x      => \{x}
  | typ_arrow T1 T2 => (typ_fv T1) \u (typ_fv T2)
  | typ_unit        => \{}
  | typ_nat         => \{}
  | typ_prod T1 T2  => (typ_fv T1) \u (typ_fv T2)
  | typ_sum T1 T2   => (typ_fv T1) \u (typ_fv T2)
  | typ_ref T1      => (typ_fv T1)
  end.

(** Exceptions is an abstract typ. typ_unit can be a naive implementation
    of exceptions, but to be able to pattern match on exceptions one may
    rather consider defining exception as a sum of types.
    The exception type must be ground (no free type variable). *)

Parameter typ_exn : typ.
Parameter typ_exn_fresh : typ_fv typ_exn = \{}.

(** Type schemes. *)

Record sch : Set := Sch {
  sch_arity : nat ;
  sch_type  : typ }.

(** Opening body of type schemes. *)

Fixpoint typ_open (T : typ) (Vs : list typ) {struct T} : typ :=
  match T with
  | typ_bvar i      => List.nth i Vs typ_def
  | typ_fvar x      => typ_fvar x
  | typ_arrow T1 T2 => typ_arrow (typ_open T1 Vs) (typ_open T2 Vs)
  | typ_unit        => typ_unit
  | typ_nat         => typ_nat
  | typ_prod T1 T2  => typ_prod (typ_open T1 Vs) (typ_open T2 Vs)
  | typ_sum T1 T2   => typ_sum (typ_open T1 Vs) (typ_open T2 Vs)
  | typ_ref T1      => typ_ref (typ_open T1 Vs)
  end.

(** Opening body of type schemes with variables *)

Definition typ_fvars :=
  LibList.map typ_fvar.

Definition typ_open_vars T Xs :=
  typ_open T (typ_fvars Xs).

(** Instanciation of a type scheme *)

Definition sch_open M :=
  typ_open (sch_type M).

Definition sch_open_vars M :=
  typ_open_vars (sch_type M).

Notation "M ^^ Vs" := (sch_open M Vs)
  (at level 67, only parsing) : typ_scope.
Notation "M ^ Xs" :=
  (sch_open_vars M Xs) (only parsing) : typ_scope.

Bind Scope typ_scope with typ.
Open Scope typ_scope.

(** Locally closed types *)

Inductive type : typ -> Prop :=
  | type_fvar : forall X,
      type (typ_fvar X)
  | type_arrow : forall T1 T2,
      type T1 ->
      type T2 ->
      type (typ_arrow T1 T2)
  | type_unit :
      type (typ_unit)
  | type_nat :
      type (typ_nat)
  | type_prod : forall T1 T2,
      type T1 ->
      type T2 ->
      type (typ_prod T1 T2)
  | type_sum : forall T1 T2,
      type T1 ->
      type T2 ->
      type (typ_sum T1 T2)
  | type_ref : forall T1,
      type T1 ->
      type (typ_ref T1).

(** List of n locally closed types *)

Definition types := list_for_n type.

(** Body of a scheme *)

Definition typ_body n T :=
  exists L, forall Xs,
  fresh L n Xs ->
  type (typ_open_vars T Xs).

(** Definition of a well-formed scheme *)

Definition scheme M :=
   typ_body (sch_arity M) (sch_type M).

(* ********************************************************************** *)
(** ** Description of terms *)

(** Definition of locations. *)

Definition loc := var.

(** Grammar of patterns. *)

Inductive pat : Set :=
  | pat_bvar : pat
  | pat_wild : pat
  | pat_unit : pat
  | pat_pair : pat -> pat -> pat
  | pat_inj1 : pat -> pat
  | pat_inj2 : pat -> pat.

(** Grammar of terms. *)

Inductive trm : Set :=
  | trm_bvar  : nat -> nat -> trm
  | trm_fvar  : var -> trm
  | trm_abs   : trm -> trm
  | trm_fix   : trm -> trm
  | trm_let   : trm -> trm -> trm
  | trm_match : trm -> pat -> trm -> trm -> trm
  | trm_app   : trm -> trm -> trm
  | trm_unit  : trm
  | trm_nat   : nat -> trm
  | trm_add  : trm
  | trm_pair  : trm -> trm -> trm
  | trm_inj1  : trm -> trm
  | trm_inj2  : trm -> trm
  | trm_loc   : loc -> trm
  | trm_ref   : trm -> trm
  | trm_get   : trm -> trm
  | trm_set   : trm -> trm -> trm
  | trm_raise : trm -> trm
  | trm_catch : trm -> trm -> trm.

(** [trm] is inhabited *)

Definition trm_def := trm_unit.
Instance trm_inhab : Inhab trm.
Proof. intros. apply (prove_Inhab trm_unit). Defined.

(** Arity of a pattern. *)

Fixpoint pat_arity (p : pat) : nat :=
  match p with
  | pat_bvar       => 1
  | pat_wild       => 0
  | pat_unit       => 0
  | pat_pair p1 p2 => (pat_arity p1) + (pat_arity p2)
  | pat_inj1 p1    => (pat_arity p1)
  | pat_inj2 p1    => (pat_arity p1)
  end.

(** Pattern matching. *)

Fixpoint pat_match (p : pat) (t : trm) {struct p} : option (list trm) :=
  match p, t with
  | pat_bvar      , t1             => Some (t1::nil)
  | pat_wild      , t1             => Some nil
  | pat_unit      , trm_unit       => Some nil
  | pat_pair p1 p2, trm_pair t1 t2 => match (pat_match p1 t1), (pat_match p2 t2) with
                                      | Some r1, Some r2 => Some (r1 ++ r2)
                                      | _      , _       => None end
  | pat_inj1 p1   , trm_inj1 t1    => (pat_match p1 t1)
  | pat_inj2 p1   , trm_inj2 t1    => (pat_match p1 t1)
  | _             , _              => None
  end.

(** nth function on term lists *)

Definition trm_nth n (ts : list trm) := List.nth n ts trm_def.

(** Opening up abstractions *)

Fixpoint opens_rec (k : nat) (us : list trm) (t : trm) {struct t} : trm :=
  match t with
  | trm_bvar i j  => If k = i then (trm_nth j us) else (trm_bvar i j)
  | trm_fvar x    => trm_fvar x
  | trm_abs t1    => trm_abs (opens_rec (S k) us t1)
  | trm_fix t1    => trm_fix (opens_rec (S k) us t1)
  | trm_let t1 t2 => trm_let (opens_rec k us t1) (opens_rec (S k) us t2)
  | trm_match t1 p1 b t2 => trm_match (opens_rec k us t1) p1
                               (opens_rec (S k) us b)
                               (opens_rec (S k) us t2)
  | trm_app t1 t2 => trm_app (opens_rec k us t1) (opens_rec k us t2)
  | trm_unit      => trm_unit
  | trm_nat n     => trm_nat n
  | trm_add       => trm_add
  | trm_pair t1 t2 => trm_pair (opens_rec k us t1) (opens_rec k us t2)
  | trm_inj1 t1   => trm_inj1 (opens_rec k us t1)
  | trm_inj2 t1   => trm_inj2 (opens_rec k us t1)
  | trm_loc l     => trm_loc l
  | trm_ref t1    => trm_ref (opens_rec k us t1)
  | trm_get t1    => trm_get (opens_rec k us t1)
  | trm_set t1 t2 => trm_set (opens_rec k us t1) (opens_rec k us t2)
  | trm_raise t1    => trm_raise (opens_rec k us t1)
  | trm_catch t1 t2 => trm_catch (opens_rec k us t1) (opens_rec k us t2)
  end.

Definition opens t us := opens_rec 0 us t.
Definition open t u := opens t (u::nil).
Definition trm_fvars := LibList.map trm_fvar.

Notation "{ k ~> u } t" := (opens_rec k u t) (at level 67).
Notation "t ^^ us" := (opens t us) (at level 67).
Notation "t ^ xs" := (opens t (trm_fvars xs)).

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

Inductive term : trm -> Prop :=
  | term_var : forall x,
      term (trm_fvar x)
  | term_abs : forall L t1,
      (forall x, fresh L 1 (x::nil) ->
        term (t1 ^ (x::nil))) ->
      term (trm_abs t1)
  | term_fix : forall L t1,
      (forall f x, fresh L 2 (x::f::nil) ->
        term (t1 ^ (x::f::nil))) ->
      term (trm_fix t1)
  | term_let : forall L t1 t2,
      term t1 ->
      (forall x, fresh L 1 (x::nil) ->
        term (t2 ^ (x::nil))) ->
      term (trm_let t1 t2)
  | term_match : forall L t1 p b t2,
      term t1 ->
      (forall xs, fresh L (pat_arity p) xs -> term (b ^ xs)) ->
      term t2 ->
      term (trm_match t1 p b t2)
  | term_app : forall t1 t2,
      term t1 ->
      term t2 ->
      term (trm_app t1 t2)
  | term_unit :
      term (trm_unit)
  | term_nat : forall n,
      term (trm_nat n)
  | term_add :
      term (trm_add)
  | term_pair : forall t1 t2,
      term t1 ->
      term t2 ->
      term (trm_pair t1 t2)
  | term_inj1 : forall t1,
      term t1 ->
      term (trm_inj1 t1)
  | term_inj2 : forall t1,
      term t1 ->
      term (trm_inj2 t1)
  | term_loc : forall l,
      term (trm_loc l)
  | term_new : forall t1,
      term t1 ->
      term (trm_ref t1)
  | term_get : forall t1,
      term t1 ->
      term (trm_get t1)
  | term_set : forall t1 t2,
      term t1 ->
      term t2 ->
      term (trm_set t1 t2)
  | term_raise : forall t1,
      term t1 ->
      term (trm_raise t1)
  | term_catch : forall t1 t2,
      term t1 ->
      term t2 ->
      term (trm_catch t1 t2).

(** Definition of [bodys n t] as [t ^ xs] is a term when [|xs|=n] *)

Definition bodys n t :=
  exists L, forall xs,
  fresh L n xs -> term (t ^ xs).

(* ********************************************************************** *)
(** ** Semantics *)

(** Representation of the store and its well-formedness judgment *)

Definition sto := LibEnv.env trm.

Inductive sto_ok : sto -> Prop :=
  | sto_ok_empty : sto_ok empty
  | sto_ok_push : forall mu l t,
      sto_ok mu -> term t ->
      sto_ok (mu & l ~ t).

(** Grammar of values *)

Inductive value : trm -> Prop :=
  | value_abs : forall t1, term (trm_abs t1) -> value (trm_abs t1)
  | value_fix : forall t1, term (trm_fix t1) -> value (trm_fix t1)
  | value_nat : forall n, value (trm_nat n)
  | value_add : value trm_add
  | value_add_1 : forall n, value (trm_app trm_add (trm_nat n))
  | value_pair : forall v1 v2, value v1 -> value v2 -> value (trm_pair v1 v2)
  | value_inj1 : forall v1, value v1 -> value (trm_inj1 v1)
  | value_inj2 : forall v1, value v1 -> value (trm_inj2 v1)
  | value_unit : value trm_unit
  | value_loc : forall l, value (trm_loc l).

(** Raising of Exceptions *)

Inductive fails : trm -> trm -> Prop :=
  | fails_raise_val : forall t1,
      value t1 ->
      fails (trm_raise t1) t1
  | fails_app_1 : forall t1 t2 e,
      term t2 ->
      fails t1 e ->
      fails (trm_app t1 t2) e
  | fails_app_2 : forall t1 t2 e,
      value t1 ->
      fails t2 e ->
      fails (trm_app t1 t2) e
  | fails_let_1 : forall t1 t2 e,
      bodys 1 t2 ->
      fails t1 e ->
      fails (trm_let t1 t2) e
  | fails_pair_1 : forall t1 t2 e,
      term t2 ->
      fails t1 e ->
      fails (trm_pair t1 t2) e
  | fails_pair_2 : forall t1 t2 e,
      value t1 ->
      fails t2 e ->
      fails (trm_pair t1 t2) e
  | fails_inj_1 : forall t1 e,
      fails t1 e ->
      fails (trm_inj1 t1) e
  | fails_inj_2 : forall t1 e,
      fails t1 e ->
      fails (trm_inj2 t1) e
  | fails_mat_1 : forall t1 p b t2 e,
      bodys (pat_arity p) b ->
      term t2 ->
      fails t1 e ->
      fails (trm_match t1 p b t2) e
  | fails_new_1 : forall t1 e,
      fails t1 e ->
      fails (trm_ref t1) e
  | fails_get_1 : forall t1 e,
      fails t1 e ->
      fails (trm_get t1) e
  | fails_set_1 : forall t1 t2 e,
      fails t1 e ->
      term t2 ->
      fails (trm_set t1 t2) e
  | fails_set_2 : forall t1 t2 e,
      value t1 ->
      fails t2 e ->
      fails (trm_set t1 t2) e
  | fails_raise_1 : forall t1 e,
      fails t1 e ->
      fails (trm_raise t1) e.

(** Reduction rules *)

Definition conf := (trm * sto)%type.

Inductive red : conf -> conf -> Prop :=

  (* -- reduction with substitution -- *)

  | red_beta : forall mu t1 t2,
      sto_ok mu ->
      term (trm_abs t1) ->
      value t2 ->
      red (trm_app (trm_abs t1) t2, mu) (t1 ^^ (t2::nil), mu)
  | red_fix : forall mu t1 t2,
      sto_ok mu ->
      term (trm_fix t1) ->
      value t2 ->
      red (trm_app (trm_fix t1) t2, mu)
          (t1 ^^ (t2::(trm_fix t1)::nil), mu)
  | red_let : forall mu t1 t2,
      sto_ok mu ->
      term (trm_let t1 t2) ->
      value t1 ->
      red (trm_let t1 t2, mu) (t2 ^^ (t1::nil), mu)
  | red_match_some : forall ts mu t1 p b t2,
      sto_ok mu ->
      value t1 ->
      bodys (pat_arity p) b ->
      term t2 ->
      pat_match p t1 = Some ts ->
      red (trm_match t1 p b t2, mu) (b ^^ ts, mu)
  | red_match_none : forall mu t1 p b t2,
      sto_ok mu ->
      value t1 ->
      bodys (pat_arity p) b ->
      term t2 ->
      pat_match p t1 = None ->
      red (trm_match t1 p b t2, mu) (t2, mu)

  (* -- reduction of primitives -- *)

  | red_add : forall mu n1 n2,
      sto_ok mu ->
      red (trm_app (trm_app trm_add (trm_nat n1)) (trm_nat n2), mu)
          (trm_nat (n1 + n2), mu)
  | red_new : forall mu t1 l,
      sto_ok mu ->
      value t1 ->
      l # mu ->
      red (trm_ref t1, mu) (trm_loc l, (mu & l ~ t1))
  | red_get : forall mu l t,
      sto_ok mu ->
      binds l t mu ->
      red (trm_get (trm_loc l), mu) (t, mu)
  | red_set : forall mu l t2,
      sto_ok mu ->
      value t2 ->
      red (trm_set (trm_loc l) t2, mu) (trm_unit, mu & l ~ t2)
  | red_catch_val : forall mu t1 t2,
      sto_ok mu ->
      term t1 ->
      value t2 ->
      red (trm_catch t1 t2, mu) (t2, mu)
  | red_catch_exn : forall mu t1 t2 e,
      sto_ok mu ->
      term t1 ->
      fails t2 e ->
      red (trm_catch t1 t2, mu) (trm_app t1 e, mu)

  (* -- reduction under context -- *)

  | red_app_1 : forall mu mu' t1 t1' t2,
      term t2 ->
      red (t1, mu) (t1', mu') ->
      red (trm_app t1 t2, mu) (trm_app t1' t2, mu')
  | red_app_2 : forall mu mu' t1 t2 t2',
      value t1 ->
      red (t2, mu) (t2', mu') ->
      red (trm_app t1 t2, mu) (trm_app t1 t2', mu')
  | red_match_1 : forall mu mu' t1 t1' p b t2,
      term t2 ->
      bodys (pat_arity p) b ->
      red (t1, mu) (t1', mu') ->
      red (trm_match t1 p b t2, mu) (trm_match t1' p b t2, mu')
  | red_pair_1 : forall mu mu' t1 t1' t2,
      term t2 ->
      red (t1, mu) (t1', mu') ->
      red (trm_pair t1 t2, mu) (trm_pair t1' t2, mu')
  | red_pair_2 : forall mu mu' t1 t2 t2',
      value t1 ->
      red (t2, mu) (t2', mu') ->
      red (trm_pair t1 t2, mu) (trm_pair t1 t2', mu')
  | red_inj1_1 : forall mu mu' t1 t1',
      red (t1, mu) (t1', mu') ->
      red (trm_inj1 t1, mu) (trm_inj1 t1', mu')
  | red_inj2_1 : forall mu mu' t1 t1',
      red (t1, mu) (t1', mu') ->
      red (trm_inj2 t1, mu) (trm_inj2 t1', mu')
  | red_new_1 : forall mu mu' t1 t1',
      red (t1, mu) (t1', mu') ->
      red (trm_ref t1, mu) (trm_ref t1', mu')
  | red_get_1 : forall mu mu' t1 t1',
      red (t1, mu) (t1', mu') ->
      red (trm_get t1, mu) (trm_get t1', mu')
  | red_set_1 : forall mu mu' t1 t1' t2,
      red (t1, mu) (t1', mu') ->
      term t2 ->
      red (trm_set t1 t2, mu) (trm_set t1' t2, mu')
  | red_set_2 : forall mu mu' t1 t2 t2',
      value t1 ->
      red (t2, mu) (t2', mu') ->
      red (trm_set t1 t2, mu) (trm_set t1 t2', mu')

  | red_catch_2 : forall mu mu' t1 t2 t2',
      term t1 ->
      red (t2, mu) (t2', mu') ->
      red (trm_catch t1 t2, mu) (trm_catch t1 t2', mu')
  | red_raise_1 : forall mu mu' t1 t1',
      red (t1, mu) (t1', mu') ->
      red (trm_raise t1, mu) (trm_raise t1', mu').

Notation "c --> c'" := (red c c') (at level 68).

(* ********************************************************************** *)
(** ** Typing *)

(** Typing environments mapping variable to type schemes *)

Definition env := LibEnv.env sch.

(** Typing environments mapping locations to types
    and its well-formedness judgment *)

Definition phi := LibEnv.env typ.

Inductive phi_ok : phi -> Prop :=
  | phi_ok_empty : phi_ok empty
  | phi_ok_push : forall P l T,
      phi_ok P -> type T -> (*  typ_fv T = \{} -> *)
      phi_ok (P & l ~T).

(** Typing relation for patterns: if Us are the types of the
    bound variables in the pattern p, then the pattern p matches
    values of type T. *)

Reserved Notation "Us \= p ~: T" (at level 69).

Inductive pat_typing : list typ -> pat -> typ -> Prop :=
  | pat_typing_bvar : forall T,
     (T::nil) \= pat_bvar ~: T
  | pat_typing_wild : forall T,
     nil \= pat_wild ~: T
  | pat_typing_unit :
     nil \= pat_unit ~: typ_unit
  | pat_typing_pair : forall p1 p2 T1 T2 Us1 Us2,
     Us1 \= p1 ~: T1 ->
     Us2 \= p2 ~: T2 ->
     (Us1 ++ Us2) \= (pat_pair p1 p2) ~: (typ_prod T1 T2)
  | pat_typing_inj1 : forall T2 p1 T1 Us1,
     Us1 \= p1 ~: T1 ->
     Us1 \= (pat_inj1 p1) ~: (typ_sum T1 T2)
  | pat_typing_inj2 : forall T2 p1 T1 Us1,
     Us1 \= p1 ~: T2 ->
     Us1 \= (pat_inj2 p1) ~: (typ_sum T1 T2)

where "Ts \= p ~: T" := (pat_typing Ts p T).

(** The typing judgment for terms *)

Reserved Notation "E ! P |= t ~: T" (at level 69).

Inductive typing : env -> phi -> trm -> typ -> Prop :=
  | typing_var : forall E P x M Us,
      ok E -> phi_ok P ->
      binds x M E ->
      types (sch_arity M) Us ->
      scheme M ->
      E ! P |= (trm_fvar x) ~: (M ^^ Us)
  | typing_abs : forall L E P U T t1,
      type U ->
      (forall x, fresh L 1 (x::nil) ->
       (E & x ~ Sch 0 U) ! P |= t1 ^ (x::nil) ~: T) ->
      E ! P |= (trm_abs t1) ~: (typ_arrow U T)
  | typing_fix : forall L E P U T t1,
      type U ->
      (forall f x, fresh L 2 (x::f::nil) ->
        (E & f ~ Sch 0 (typ_arrow U T) & x ~ Sch 0 U) ! P |= t1 ^ (x::f::nil) ~: T) ->
      E ! P |= (trm_fix t1) ~: (typ_arrow U T)
  | typing_let : forall M L1 L2 E P T2 t1 t2,
      value t1 ->
      scheme M ->
      (forall Xs, fresh L1 (sch_arity M) Xs ->
         E ! P |= t1 ~: (M ^ Xs)) ->
      (forall x, fresh L2 1 (x::nil) ->
         (E & x ~ M) ! P |= (t2 ^ (x::nil)) ~: T2) ->
      E ! P |= (trm_let t1 t2) ~: T2
  | typing_match : forall T Us L R E P t1 p b t2,
      E ! P |= t1 ~: T ->
      Us \= p ~: T ->
      (forall xs, fresh L (pat_arity p) xs ->
        (E & (xs ~* (LibList.map (Sch 0) Us))) ! P |= (b ^ xs) ~: R) ->
      E ! P |= t2 ~: R ->
      E ! P |= (trm_match t1 p b t2) ~: R
  | typing_app : forall E P S T t1 t2,
      E ! P |= t1 ~: (typ_arrow S T) ->
      E ! P |= t2 ~: S ->
      E ! P |= (trm_app t1 t2) ~: T
  | typing_unit : forall E P,
      ok E -> phi_ok P ->
      E ! P |= (trm_unit) ~: (typ_unit)
  | typing_nat : forall E P n,
      ok E -> phi_ok P ->
      E ! P |= (trm_nat n) ~: (typ_nat)
  | typing_add : forall E P,
      ok E -> phi_ok P ->
      E ! P |= trm_add ~: (typ_arrow typ_nat (typ_arrow typ_nat typ_nat))
  | typing_pair : forall E P t1 t2 T1 T2,
      E ! P |= t1 ~: T1 ->
      E ! P |= t2 ~: T2 ->
      E ! P |= (trm_pair t1 t2) ~: (typ_prod T1 T2)
  | typing_inj1 : forall T2 E P t1 T1,
      type T2 ->
      E ! P |= t1 ~: T1 ->
      E ! P |= (trm_inj1 t1) ~: (typ_sum T1 T2)
  | typing_inj2 : forall T1 E P t1 T2,
      type T1 ->
      E ! P |= t1 ~: T2 ->
      E ! P |= (trm_inj2 t1) ~: (typ_sum T1 T2)
  | typing_loc : forall E P l T,
      ok E -> phi_ok P ->
      binds l T P ->
      E ! P |= (trm_loc l) ~: (typ_ref T)
  | typing_ref : forall E P t1 T,
      E ! P |= t1 ~: T ->
      E ! P |= (trm_ref t1) ~: (typ_ref T)
  | typing_get : forall E P t1 T,
      E ! P |= t1 ~: (typ_ref T) ->
      E ! P |= (trm_get t1) ~: T
  | typing_set : forall E P t1 t2 T,
      E ! P |= t1 ~: (typ_ref T) ->
      E ! P |= t2 ~: T ->
      E ! P |= (trm_set t1 t2) ~: typ_unit
  | typing_raise : forall E P t1 T,
      type T ->
      E ! P |= t1 ~: typ_exn ->
      E ! P |= (trm_raise t1) ~: T
  | typing_catch : forall E P t1 t2 T,
      E ! P |= t1 ~: (typ_arrow typ_exn T) ->
      E ! P |= t2 ~: T ->
      E ! P |= (trm_catch t1 t2) ~: T

where "E ! P |= t ~: T" := (typing E P t T).

(** Typing store *)

Definition sto_typing P mu :=
     phi_ok P
  /\ sto_ok mu
  /\ (forall l, l # mu -> l # P)
  /\ (forall l T, binds l T P ->
        exists t, binds l t mu
               /\ empty ! P |= t ~: T).

Notation "P |== mu" := (sto_typing P mu) (at level 68).

(* ********************************************************************** *)
(** ** Theorems *)

(** Preservation: if t has type T in the empty context and under
    P typing the store mu, and if t reduces to t' by updating
    the context to mu', then there exists a extended relation P'
    typing the new store mu', such that t' has its typed preserved
    under P'. *)

Definition preservation := forall P t t' mu mu' T,
  empty ! P |= t ~: T ->
  (t,mu) --> (t',mu') ->
  P |== mu ->
  exists P',
     extends P P'
  /\ empty ! P' |= t' ~: T
  /\ P' |== mu'.

(** Progress: If a term t has type T in the empty environment and
    under P typing the store mu, then three cases are possibles:
    (1) t is a value, (2) t raises an exception e, or (3) there
    exists a term t' and a store mu' such that the configuration
    (t,mu) reduces to the configuration (t',mu'). *)

Definition progress := forall P t mu T,
  empty ! P |= t ~: T ->
  P |== mu ->
     value t
  \/ (exists e, fails t e)
  \/ (exists t', exists mu', (t,mu) --> (t',mu')).


Require Import Metalib.Metatheory.
Require Import Program.Equality.
Require Export definition.

Lemma decide_Mode : forall x y : Mode, {x = y} + {~ x = y}.
  intros.
  decide equality.
Defined.

Lemma subst_tt_intro_rec : forall X T2 U k,
  X `notin` fv_tt T2 ->
  open_tt_rec k U T2 = subst_tt X U (open_tt_rec k (typ_fvar X) T2).
Proof with congruence || auto.
  induction T2; intros U k Fr; simpl in *; f_equal...

    destruct (k === n)... simpl. destruct (X == X)...

    destruct (a == X)... contradict Fr; fsetdec.
Qed.

Lemma subst_tt_intro : forall X T2 U,
  X `notin` fv_tt T2 ->
  open_tt T2 U = subst_tt X U (open_tt T2 X).
Proof.
  intros.
  unfold open_tt.
  apply subst_tt_intro_rec...
  assumption.
Qed.

Lemma open_tt_rec_type_aux : forall T j V i U,
  i <> j ->
  open_tt_rec j V T = open_tt_rec i U (open_tt_rec j V T) ->
  T = open_tt_rec i U T.
Proof with congruence || eauto.
  induction T; intros j V i U Neq H; simpl in *; inversion H; f_equal...
    destruct (j === n)... destruct (i === n)...
Qed.

Lemma open_tt_rec_type : forall T U k,
  type T ->
  T = open_tt_rec k U T.
Proof with auto.
  intros T U k Htyp. revert k.
  induction Htyp; intros k; simpl; f_equal...

    unfold open_tt in *.
    pick fresh X.
    apply open_tt_rec_type_aux with (j:=0) (V:=X).
    auto.
    auto.
Qed.

Lemma subst_tt_fresh : forall Z U T,
   Z `notin` fv_tt T ->
   T = subst_tt Z U T.
Proof with auto.
  induction T; simpl; intro H; f_equal...

    destruct (a == Z)...
    contradict H; fsetdec.
Qed.

Lemma subst_tt_open_tt_rec : forall T1 T2 X P k,
  type P ->
  subst_tt X P (open_tt_rec k T2 T1) =
    open_tt_rec k (subst_tt X P T2) (subst_tt X P T1).
Proof with auto.
  intros T1 T2 X P k WP. revert k.
  induction T1; intros k; simpl; f_equal...

    destruct (k === n); subst...

    destruct (a == X); subst... apply open_tt_rec_type...
Qed.

Lemma subst_tt_open_tt : forall T1 T2 (X:atom) P,
  type P ->
  subst_tt X P (open_tt T1 T2) = open_tt (subst_tt X P T1) (subst_tt X P T2).
Proof with auto.
  intros.
  unfold open_tt.
  apply subst_tt_open_tt_rec...
Qed.

Lemma subst_tt_open_tt_var : forall (X Y:atom) P T,
  Y <> X ->
  type P ->
  open_tt (subst_tt X P T) Y = subst_tt X P (open_tt T Y).
Proof with congruence || auto.
  intros X Y P T Neq Wu.
  unfold open_tt.
  rewrite subst_tt_open_tt_rec...
  simpl.
  destruct (Y == X)...
Qed.

Lemma subst_tt_rt_type : forall Z P T,
  rt_type T ->
  type P ->
  rt_type (subst_tt Z P T).
Proof with auto.
  intros.
  induction H...
  constructor...
Qed.

Lemma subst_tt_type : forall Z P T,
  type T ->
  type P ->
  type (subst_tt Z P T).
Proof with auto.
  intros Z P T HT HP.
  induction HT; simpl...

  destruct (X == Z)...

    pick fresh Y and apply type_mu...
    rewrite subst_tt_open_tt_var...

    constructor...
    apply subst_tt_rt_type...
Qed.

Lemma open_ee_rec_expr_aux : forall e j v u i,
  i <> j ->
  open_ee_rec j v e = open_ee_rec i u (open_ee_rec j v e) ->
  e = open_ee_rec i u e.
Proof with congruence || eauto.
  induction e; intros j v u i Neq H; simpl in *; inversion H; f_equal...

    destruct (j===n)... destruct (i===n)...
Qed.

Lemma open_ee_rec_expr : forall u e k,
  expr e ->
  e = open_ee_rec k u e.
Proof with auto.
  intros u e k Hexpr. revert k.
  induction Hexpr; intro k; simpl; f_equal; auto*;
  try solve [
    unfold open_ee in *;
    pick fresh x;
    eapply open_ee_rec_expr_aux with (j := 0) (v := exp_fvar x);
    auto
  | unfold open_te in *;
    pick fresh X;
    eapply open_ee_rec_type_aux with (j := 0) (V := typ_fvar X);
    auto
  ].
Qed.

Lemma subst_ee_fresh : forall (x: atom) u e,
  x `notin` fv_exp e ->
  e = subst_ee x u e.
Proof with auto.
  intros x u e; induction e; simpl; intro H; f_equal...

    destruct (a==x)...
    contradict H; fsetdec.
Qed.

Lemma subst_ee_open_ee_rec : forall e1 e2 x u k,
  expr u ->
  subst_ee x u (open_ee_rec k e2 e1) =
    open_ee_rec k (subst_ee x u e2) (subst_ee x u e1).
Proof with auto.
  intros e1 e2 x u k WP. revert k.
  induction e1; intros k; simpl; f_equal...

    destruct (k === n); subst...

    destruct (a == x); subst... apply open_ee_rec_expr...
Qed.

Lemma subst_ee_open_ee : forall e1 e2 x u,
  expr u ->
  subst_ee x u (open_ee e1 e2) =
    open_ee (subst_ee x u e1) (subst_ee x u e2).
Proof with auto.
  intros.
  unfold open_ee.
  apply subst_ee_open_ee_rec...
Qed.

Lemma subst_ee_open_ee_var : forall (x y:atom) u e,
  y <> x ->
  expr u ->
  open_ee (subst_ee x u e) y = subst_ee x u (open_ee e y).
Proof with congruence || auto.
  intros x y u e Neq Wu.
  unfold open_ee.
  rewrite subst_ee_open_ee_rec...
  simpl.
  destruct (y == x)...
Qed.

Lemma subst_ee_intro_rec : forall x e u k,
  x `notin` fv_exp e ->
  open_ee_rec k u e = subst_ee x u (open_ee_rec k (exp_fvar x) e).
Proof with congruence || auto.
  induction e; intros u k Fr; simpl in *; f_equal...

    destruct (k === n)... simpl. destruct (x == x)...

    destruct (a == x)... contradict Fr; fsetdec.
Qed.

Lemma subst_ee_intro : forall x e u,
  x `notin` fv_exp e ->
  open_ee e u = subst_ee x u (open_ee e x).
Proof with auto.
  intros.
  unfold open_ee.
  apply subst_ee_intro_rec...
Qed.

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

Lemma In_lemmaR : forall {X: Type} (E1:list X) A  E2,
    In A E2 -> In A (E1 ++ E2).
Proof.
  induction E1; intros. simpl. auto.
  rewrite <- app_comm_cons.
  apply in_cons.
  apply  IHE1.
  assumption.
Qed.

Lemma In_lemmaL : forall {X: Type}  E2 (E1:list X) A,
    In A E1 -> In A ( E1 ++ E2).
Proof.
  induction E2;intros.
  -
    rewrite app_nil_r.
    assumption.
  -
    rewrite cons_app_one.
    rewrite <- app_assoc.
    apply IHE2.
    apply in_split in H.
    destruct H.
    destruct H.
    rewrite H.
    rewrite app_assoc.
    apply In_lemmaR.
    rewrite cons_app_one.
    rewrite app_assoc.
    rewrite <-cons_app_one.
    apply in_eq.
Qed.

Lemma notin_fv_subst: forall X A B Y,
    X \notin fv_tt A ->
    X \notin fv_tt B ->
    X <> Y ->
    X \notin fv_tt (subst_tt Y A B).
Proof with auto.
  intros.
  induction B;simpl in *...
  destruct (a == Y)...
Qed.

Lemma notin_union: forall X A B,
    X `notin` (union A B) <->
    X `notin` A /\ X `notin` B.
Proof.
  intros.
  split.
  split; auto.
  intros.
  destruct H.
  auto.
Qed.

Lemma notin_fv_tt_open : forall X U T,
    X `notin` fv_tt T ->
    X \notin fv_tt U ->
    X `notin` fv_tt (open_tt T U).
Proof with auto.
  intros.
  simpl.
  unfold open_tt.
  unfold open_tt_rec.
  generalize 0.
  induction T;simpl in *;intros...
  destruct (n0==n)...
Qed.

Lemma in_dec: forall T X,
    X \notin T \/ X \in T.
Proof with auto.
  intros.
  apply notin_diff_1.
  assert (AtomSetImpl.diff T T [=] Metatheory.empty).
  apply AtomSetProperties.diff_subset_equal.
  apply KeySetProperties.subset_refl.
  rewrite H...
Qed.

Lemma in_open: forall A X Y,
    X `in` fv_tt A ->
    X <> Y ->
    X `in` fv_tt (open_tt A Y).
Proof with auto.
  intros A X Y.
  unfold open_tt.
  generalize 0.
  induction A;intros;simpl in *...
  apply AtomSetProperties.FM.empty_iff in H.
  destruct H.
  apply AtomSetImpl.union_1 in H.
  destruct H.
  apply AtomSetImpl.union_2.
  apply IHA1...
  apply AtomSetImpl.union_3.
  apply IHA2...
  apply AtomSetImpl.union_1 in H.
  destruct H.
  apply AtomSetImpl.union_2.
  apply IHA1...
  apply AtomSetImpl.union_3.
  apply IHA2...
Qed.

Lemma open_rec_eq :
  forall A1 A2 X n,
    open_tt_rec n (typ_fvar X) A1 = open_tt_rec n X A2 ->
    X \notin (union (fv_tt A1) (fv_tt A2)) ->
    A1 = A2.
Proof with auto.
  induction A1; intros; simpl in *.
  -
    destruct A2; simpl in *; try (inversion H); eauto.
    destruct (n == n0); inversion H.
  - destruct A2; simpl in *; try (inversion H); eauto.
    destruct (n == n0); inversion H.
  - destruct (n0 == n).
    destruct A2; simpl in *; try (inversion H); eauto.
    destruct (n0 == n1); subst; eauto.
    inversion H. subst.
    apply notin_union in H0.
    destruct H0.
    apply notin_singleton_1 in H1.
    destruct H1...
    destruct A2; simpl in *; try (inversion H); eauto.
    destruct (n0 == n2); try (inversion H).
    subst. eauto.
  - destruct A2; simpl in *; try (inversion H); eauto.
    destruct (n == n0); try (inversion H).
    apply notin_union in H0.
    destruct H0.
    apply notin_singleton_1 in H0.
    destruct H0...
  - destruct A2; simpl in *; try (inversion H); eauto.
    destruct (n == n0); inversion H.
    apply IHA1 in H2; eauto. rewrite H2.
    eauto.
  - destruct A2; simpl in *; try (inversion H); eauto.
    destruct (n == n0); inversion H.
    apply IHA1_1 in H2; eauto.
    apply IHA1_2 in H3; eauto.
    subst. eauto.
  -
    destruct A2; simpl in *; try (inversion H); eauto.
    destruct (n == n0); inversion H.
  -
    destruct A2; simpl in *; try (inversion H); eauto.
    destruct (n == n0); inversion H.
    apply IHA1_1 in H3; eauto.
    apply IHA1_2 in H4; eauto.
    subst. eauto.
Qed.

Lemma chooseS_arrow : forall m X C D A1 A2,
    chooseS m X C D (typ_arrow A1 A2) = typ_arrow (chooseS m X C D A1) (chooseS m X C D A2).
  intros. destruct m; simpl in *; eauto.
Defined.

Lemma chooseS_mu : forall m X C D A,
    chooseS m X C D (typ_mu A) = typ_mu (chooseS m X C D A).
  intros. destruct m; simpl in *; eauto.
Defined.

Lemma chooseS_rcd_cons : forall i m X C D A B,
    chooseS m X C D (typ_rcd_cons i A B) = typ_rcd_cons i (chooseS m X C D A) (chooseS m X C D B).
Proof with auto.
  intros. destruct m; simpl in *; eauto.
Defined.

Lemma chooseS_rcd_nil : forall  m X C D ,
    chooseS m X C D (typ_rcd_nil ) = typ_rcd_nil.
Proof with auto.
  intros. destruct m; simpl in *; eauto.
Defined.

Lemma chooseS_open: forall C X D  A (Y : atom) m,
    X <> Y ->
    type D -> type C ->
    chooseS m X C D (open_tt A Y) = open_tt (chooseS m X C D A) Y.
Proof with auto.
  intros.
  unfold chooseS.
  destruct m...
  rewrite subst_tt_open_tt...
  f_equal...
  rewrite <- subst_tt_fresh ...
  rewrite subst_tt_open_tt...
  f_equal...
  rewrite <- subst_tt_fresh ...
Qed.

Lemma chooseS_open2: forall C X D  A (Y : atom) m,
    X <> Y ->
    type D -> type C ->
    chooseS m X C D (open_tt A (open_tt A Y)) = open_tt (chooseS m X C D A) (open_tt (chooseS m X C D A) Y).
Proof with auto.
  intros.
  unfold chooseS.
  destruct m.
  rewrite subst_tt_open_tt ...
  f_equal...
  rewrite subst_tt_open_tt_var...
  rewrite subst_tt_open_tt ...
  f_equal...
  rewrite subst_tt_open_tt_var...
Qed.


Require Export B4_Droite_Def.

Section BETWEEN_PRELIMINARS.

Lemma BetweenDistinctAB : forall A B C, Between A B C -> A <> B.
Proof.
	canonize.
Qed.

Lemma BetweenNotClockwiseABC : forall A B C,
	Between A B C -> ~Clockwise A B C.
Proof.
	canonize.
	elim (NotClockwiseBAA C B).
	auto.
Qed.

Lemma ClockwiseNotBetweenABC : forall A B C,
	Clockwise A B C -> ~Between A B C.
Proof.
	canonize.
	elim (NotClockwiseBAA C B); auto.
Qed.

Lemma BetweenNotClockwiseBAC : forall A B C,
	Between A B C -> ~Clockwise B A C.
Proof.
	generalizeChange.
	elim (NotClockwiseBAA A B).
	apply H3; apply ClockwiseCAB; trivial.
Qed.

Lemma BetweenHalfLine : forall A B C,
	Between A B C -> HalfLine A B C.
Proof.
	intros; decompose [or] (FourCases A B C).
	 elim (BetweenNotClockwiseABC A B C H); trivial.
	 elim (BetweenNotClockwiseBAC A B C H); trivial.
	 trivial.
	 generalizeChange; elim (ClockwiseNotClockwise A B x); auto.
Qed.

Lemma BetweenSymHalfLine : forall A B C,
	Between A B C -> HalfLine C B A.
Proof.
	intros; decompose [or] (FourCases C B A).
	 elim (BetweenNotClockwiseBAC A B C H); apply ClockwiseBCA; trivial.
	 elim (BetweenNotClockwiseABC A B C H); apply ClockwiseCAB; trivial.
	 trivial.
	 generalizeChange; elim (ClockwiseNotClockwise B A x); auto.
Qed.

End BETWEEN_PRELIMINARS.


(**
    Authors: Steve Zdancewic and Karl Mazurak and Jianzhou Zhao.
*)

Require Export Bang_Soundness.
Require Import Omega.
Require Import Tactics.

(* Decidability results: *)
Lemma eq_bnd_dec: forall (a b:binding), {a = b}+{~a=b}.
Proof.
  decide equality. apply eq_typ_dec.
Qed.

Lemma eq_binding_dec: forall (x y:(atom * binding)%type), {x = y}+{~x = y}.
Proof.
  decide equality. apply eq_bnd_dec.
Qed.

Lemma binds_dec: forall x b (E:env),
  {binds x b E} + {~binds x b E}.
Proof.
  intros. unfold binds. apply List.In_dec.
  decide equality.
  apply eq_bnd_dec.
Qed.

Lemma wf_typ_rename : forall G T (x y:atom),
  uniq G ->
  y `notin` (singleton x `union` fv_tt T `union` dom G)  ->
  x `notin` (fv_tt T `union` dom G) ->
  wf_typ ([(x, bind_kn)] ++ G) (open_tt T x) ->
  wf_typ ([(y, bind_kn)] ++ G) (open_tt T y).
Proof.
  intros.
  rewrite (subst_tt_intro x).
  rewrite_env (nil ++ [(y, bind_kn)] ++ G).
  assert (nil = map (subst_tb x y) nil).
  simpl. auto.
  rewrite H3.
  eapply wf_typ_subst_tb. simpl_env.
  eapply wf_typ_weakening. eauto.
    simpl. apply uniq_cons; auto. simpl.
  apply wf_typ_var. apply uniq_cons. auto. solve_notin.
  rewrite_env ([(y, bind_kn)] ++ G).
  apply binds_app_l. apply binds_one; auto. solve_notin.
Qed.

Lemma wf_all_exists : forall T (x:atom) G,
  uniq G ->
  x `notin` (fv_tt T `union` dom G) ->
  wf_typ ([(x, bind_kn)] ++ G) (open_tt T x) ->
  wf_typ G (typ_all T).
Proof.
  intros.
  pick fresh y and apply wf_typ_all.
  apply (wf_typ_rename G T x). auto. solve_notin. auto. auto.
Qed.

Lemma wf_typ_dec: forall G T,
  uniq G ->
  type T ->
  (wf_typ G T) \/ (~wf_typ G T).
Proof.
  intros G T Uniq Hyp. generalize dependent G.
  induction Hyp; intros G Uniq; auto.

  Case "fvar".
    destruct (binds_dec X (bind_kn) G).
    left. apply wf_typ_var; auto.
    right. unfold not; intros. inversion H. apply n; auto.

  Case "arrow".
    destruct (IHHyp1 G Uniq);
    destruct (IHHyp2 G Uniq);
    try eapply wf_typ_arrow; eauto.
      right. unfold not; intros. inversion H1. subst; auto.
      right. unfold not; intros. inversion H1. subst; auto.
      right. unfold not; intros. inversion H1. subst; auto.

  Case "all".
    pick fresh y.
    assert  (FR: y `notin` L).
    solve_notin.
    destruct (H0 y FR ([(y, bind_kn)] ++ G)).
      simpl. apply uniq_cons. auto. solve_notin.
      left. apply (wf_all_exists T1 y). auto. solve_notin. auto.
      right. unfold not. intros. inversion H2. subst.
      pick fresh z. lapply (H5 z); auto. intros.
      apply H1. apply (wf_typ_rename G T1 z y). auto. solve_notin.
        solve_notin. auto.

  Case "bang".
    destruct (IHHyp G Uniq).
      left; auto.
      right. intro J. inversion J; subst; auto.

  Case "with".
    destruct (IHHyp1 G Uniq); destruct (IHHyp2 G Uniq);
      try eapply wf_typ_with; eauto.
      right. unfold not; intros. inversion H1. subst; auto.
      right. unfold not; intros. inversion H1. subst; auto.
      right. unfold not; intros. inversion H1. subst; auto.
Qed.

Lemma wf_env_inversion: forall E2 E1 x T,
  wf_env (E2 ++ [(x, bind_typ T)] ++ E1) ->
  wf_typ E1 T.
Proof.
  induction E2; intros E1 x T WF.
  simpl_env in WF. inversion WF.  auto.
  eapply IHE2. rewrite_env ([a] ++ E2 ++ [(x, bind_typ T)] ++ E1) in WF.
  inversion WF. simpl_env in H1. apply H1. apply H1.
Qed.

Lemma fv_tt_in_open: forall X Y T n,
  X `in` fv_tt T -> X `in` fv_tt (open_tt_rec n (typ_fvar Y) T).
Proof.
  intros X Y T.
  induction T; intros; unfold open_tt in *; simpl in *; try (simpl; subst; fsetdec; auto).
  assert (X `in` (fv_tt T1) \/ X `in` (fv_tt T2)).
    fsetdec.
  destruct H0.
    assert (X `in` (fv_tt (open_tt_rec n Y T1))).
      apply IHT1; auto.
    fsetdec.
    assert (X `in` fv_tt (open_tt_rec n Y T2)).
      apply IHT2; auto.
    fsetdec.
  apply IHT; auto.
  apply IHT; auto.
  assert (X `in` (fv_tt T1) \/ X `in` (fv_tt T2)).
    fsetdec.
  destruct H0.
    assert (X `in` (fv_tt (open_tt_rec n Y T1))).
      apply IHT1; auto.
    fsetdec.
    assert (X `in` fv_tt (open_tt_rec n Y T2)).
      apply IHT2; auto.
    fsetdec.
Qed.

Lemma fv_tt_in_wf_typ: forall E T,
  wf_typ E T ->
  (forall x, x `in` fv_tt T -> x `in` dom E).
Proof.
  intros E T H.
  induction H; intros.
  Case "var".
  simpl in H1. assert (x = X). fsetdec.
  subst x. eapply binds_In. apply H0.
  Case "arrow".
  simpl in H1. assert ((x `in` fv_tt T1) \/ (x `in` fv_tt T2)).
  fsetdec. destruct H2. apply IHwf_typ1; auto. apply IHwf_typ2; auto.
  Case "all".
  pick fresh Y.
  lapply (H0 Y). intros.  lapply (H2 x). intros.
  destruct (x == Y).
    subst. assert False. apply Fr. fsetdec. tauto.
    rewrite dom_app in H3. simpl in H3. fsetdec.
    simpl in H1. unfold open_tt.  apply fv_tt_in_open. auto.
    solve_notin.
  Case "bang".
  simpl in H0. auto.
  Case "with".
  simpl in H1. assert ((x `in` fv_tt T1) \/ (x `in` fv_tt T2)).
  fsetdec. destruct H2. apply IHwf_typ1; auto. apply IHwf_typ2; auto.
Qed.

Lemma uniq_from_wf_typ:  forall E T,
  wf_typ E T ->
  uniq E.
Proof.
  intros E T Hyp.
  induction Hyp; auto.
  pick fresh Y. lapply (H0 Y). intros. eapply uniq_app_2; auto. eauto.
Qed.

Lemma disjoint_dom: forall E1 E2 E3 T,
  wf_typ (E1 ++ E2 ++ E3) T ->
  wf_typ (E1 ++ E3) T ->
  (forall x, x `in` (dom E2) -> x `notin` fv_tt T).
Proof.
  intros E1 E2 E3 T H1 H2.
  intros.
  assert (x `in` fv_tt T -> x `in` dom (E1 ++ E2 ++ E3)).
  intros.  eapply fv_tt_in_wf_typ; eauto.
  rewrite dom_app in H0. rewrite dom_app in H0. unfold not. intros.
  assert (uniq (E1 ++ E2 ++ E3)). eapply uniq_from_wf_typ; eauto.
  lapply H0. intros. assert (x `in` dom E1 \/ x `in` dom E2 \/ x `in` dom E3).
  fsetdec. destruct H6. assert (x `notin` dom E2). solve_uniq.
  apply H7; auto.
  destruct H6.
  assert (x `notin` dom E1).  solve_uniq.
  assert (x `in` dom (E1 ++ E3)). eapply fv_tt_in_wf_typ with (T:=T); auto.
  assert (x `notin` dom E3).  solve_uniq.
  rewrite dom_app in H8. fsetdec.

  assert (x `notin` dom E3).  solve_uniq. auto.

  auto.
Qed.

Lemma wf_typ_strengthening_sub: forall F E1 E2 T,
  wf_typ (E2 ++ F ++ E1) T ->
  (forall x, x `in` dom F -> x `notin` fv_tt T) ->
  wf_typ (E2 ++ E1) T.
Proof.
  induction F; intros.
  simpl in H. auto.
  apply IHF. destruct a. destruct b.
    eapply (wf_typ_strengthening_typ (F ++ E1) E2 a).
    simpl. rewrite_env (E2 ++ ((a, bind_kn) :: F) ++ E1). apply H.
    apply H0. simpl. fsetdec.
    eapply (wf_typ_strengthening (F ++ E1) E2 a t). apply H.
    intros. lapply (H0 x). intros. auto. rewrite_env ([a] ++ F). rewrite dom_app. fsetdec.
Qed.

Lemma wf_typ_strengthening_head:  forall E1 E2 T,
  wf_typ (E1 ++ E2) T ->
  wf_typ E1 T ->
  wf_typ E1 T.
Proof.
  intros E1 E2. generalize dependent E1.
  induction E2; intros E1 T H1 H2.
  simpl_env in H1. auto.
  destruct a.  assert (forall x, x `in` dom ((a,b) :: E2) -> x `notin` fv_tt T).
  intros. eapply disjoint_dom. rewrite_env (E1 ++ ((a,b)::E2) ++ nil) in H1. apply H1.
  simpl_env. apply H2. auto.
  eapply IHE2. eapply wf_typ_strengthening_sub. rewrite_env (E1 ++ [(a,b)] ++ E2) in H1.
  apply H1. intros. apply H. simpl. simpl in H0. fsetdec. apply H2.
Qed.

Lemma wf_typ_strengthening_sub2: forall E1 E2 E3 T,
  wf_typ (E1 ++ E2 ++ E3) T ->
  wf_typ (E1 ++ E3) T ->
  wf_typ (E1 ++ E3) T.
Proof.
  intros.
  eapply wf_typ_strengthening_sub. apply H.
  intros. eapply disjoint_dom.
  eapply H. eapply H0. auto.
Qed.

Lemma not_wf_env: forall E1 E2 E3 x T U,
  ~ wf_env (E1 ++ [(x, bind_typ T)] ++ E2 ++ [(x, bind_typ U)] ++ E3).
Proof.
  intros. unfold not. intros.
  assert (uniq (E1 ++ [(x, bind_typ T)] ++ E2 ++ [(x, bind_typ U)] ++ E3)).
  apply uniq_from_wf_env; auto.
  assert (~ x `in` dom ([(x, bind_typ U)] ++ E3)).
  eapply fresh_mid_tail_In.
  rewrite_env  (E1 ++ ([(x, bind_typ T)] ++ E2) ++ [(x, bind_typ U)] ++ E3) in H0.
  apply H0.
  rewrite dom_app. simpl. fsetdec.
  apply H1.
  rewrite dom_app. simpl. fsetdec.
Qed.

Lemma notin_fv_tail: forall F X T E,
 wf_env (F ++ [(X, bind_kn)] ++ E) ->
 wf_typ E T ->
 X `notin` fv_tt T.
Proof.
  intros.
  assert (forall Y, Y `in` fv_tt T -> Y `in` dom E).  intros.
  eapply fv_tt_in_wf_typ. apply H0.  auto.
  unfold not. intros.
  lapply (H1 X). intros.
  assert (uniq (F ++ [(X, bind_kn)] ++ E)). auto.
  assert (uniq (E ++ F ++ [(X, bind_kn)])). apply uniq_commute. simpl_env. auto.
  assert (X `notin` dom (F ++ [(X, bind_kn)])).
  eapply fresh_tail_In. apply H5. auto. rewrite dom_app in H6. simpl in H6. fsetdec. auto.
Qed.

Lemma in_fv_tt_dec: forall X T,
 {X `in` fv_tt T}+{~ X `in` fv_tt T}.
Proof.
  intros X T.
  induction T; simpl.
    right. fsetdec.
    destruct (X == a).
      subst. left. simpl. fsetdec.
      right. simpl. fsetdec.
    destruct IHT1.
      left. fsetdec.
      destruct IHT2.
        left. fsetdec.
        right. fsetdec.
    destruct IHT; simpl; auto.
    destruct IHT; simpl; auto.
    destruct IHT1.
      left. fsetdec.
      destruct IHT2.
        left. fsetdec.
        right. fsetdec.
Qed.

Lemma wf_lenv_uniq_lin: forall G D,
  wf_lenv G D ->
  uniq D.
Proof.
  induction D; auto.
  intros. destruct a. apply uniq_cons.
  inversion H. apply IHD; auto.
  inversion H; auto.
Qed.

Lemma map_subst_tb_id_tail : forall E G Z P,
  wf_env (E ++ G) ->
  Z `notin` dom (E ++ G) ->
  (E ++ G) = (map (subst_tb Z P) E ++ G).
Proof with auto.
  intros.
  induction E; simpl_env in *.
  auto.
  simpl. destruct a. destruct b; simpl in *.
  rewrite IHE. auto. eapply wf_env_strengthening_tail. simpl_env in H. apply H.
  fsetdec.
  rewrite <- subst_tt_fresh. rewrite IHE; auto.
  eapply wf_env_strengthening_tail. simpl_env in H. apply H.
  inversion H. subst. eapply notin_fv_wf. apply H5. rewrite dom_app.
  fsetdec.
Qed.

Lemma uniq_from_lenv_split: forall G D1 D2 D3,
  lenv_split G D1 D2 D3 ->
  uniq D3.
Proof.
  intros.
  induction H; auto.
Qed.

Lemma open_tt_type: forall T U,
  type T ->
  type (open_tt T U).
Proof.
  intros.  unfold open_tt. rewrite <- open_tt_rec_type. auto. auto.
Qed.

Lemma open_te_expr: forall e1 T,
  expr e1 ->
  expr (open_te e1 T).
Proof.
  intros. unfold open_te. rewrite <- open_te_rec_expr.
  auto. auto.
Qed.

(* The following lemma is false:
   counterexample: D1 = [] D2 = [x,y] D3 = [x,y]
                   DL = x  DR = y
   it is not the case that lenv_split E [] [x,y] [y,x]

Lemma lenv_split_exchange: forall E D1 D2 DL DR D3,
  lenv_split E D1 D2 D3 ->
  lenv_split E DL DR D3 ->
  lenv_split E D1 D2 (DR ++ DL).
Proof.
  intros E D1 D2 DL DR D3 S1.
  generalize dependent DR. generalize dependent DL.
  induction S1; intros DL DR S2.
  Case "empty".
    inversion S2; subst. simpl_env. apply lenv_split_empty.
    auto.
  Case "left".
    inversion S2; subst.
*)

Lemma wf_lenv_trivial_split: forall E D,
  wf_lenv E D ->
  lenv_split E lempty D D.
Proof.
  intros E D.
  induction D; intros.
  Case "empty".
    apply lenv_split_empty.
    inversion H; auto.
  Case "cons".
    destruct a. simpl_env in *.
    inversion H.
    apply lenv_split_right; auto.
Qed.

(*
Lemma lenv_split_exchange2: forall E D3M D1L D1M D2L D2M D3L D3R x TX,
  lenv_split E D1L D2L D3L ->
  lenv_split E D1M D2M (D3M ++ D3R) ->
  lenv_split E (D1L ++ [(x, lbind_typ TX)] ++ D1M)
               (D2L ++ D2M)
               (D3L ++ [(x, lbind_typ TX)] ++ D3M ++ D3R) ->
  lenv_split E (D1L ++ D1M ++ [(x, lbind_typ TX)])
               (D2L ++ D2M)
               (D3L ++ D3M ++ [(x, lbind_typ TX)] ++ D3R).
Proof.
  intros E D3M.
  induction D3M; intros; simpl_env in *.
*)

Lemma disjoint_split_left: forall G D1 D2 D3,
  lenv_split G D1 D2 D3 ->
  disjoint G D1.
Proof.
  intros.
  apply wf_lenv_disjoint.
  eapply wf_lenv_split_left; eauto.
Qed.

Lemma disjoint_split_right: forall G D1 D2 D3,
  lenv_split G D1 D2 D3 ->
  disjoint G D2.
Proof.
  intros.
  apply wf_lenv_disjoint.
  eapply wf_lenv_split_right; eauto.
Qed.

Lemma lenv_split_exchange_left: forall E D1L D1M D2L D2M D3L D3M x TX,
  lenv_split E D1L D2L D3L ->
  lenv_split E D1M D2M D3M ->
  lenv_split E (D1L ++ [(x, lbind_typ TX)] ++ D1M)
               (D2L ++ D2M)
               (D3L ++ [(x, lbind_typ TX)] ++ D3M) ->
  lenv_split E (D1L ++ D1M ++ [(x, lbind_typ TX)])
               (D2L ++ D2M)
               (D3L ++ D3M ++ [(x, lbind_typ TX)]).
Proof.
  intros E D1L D1M D2L D2M D3L D3M x TX S1.
  intros S2 S3.
  remember (D1L ++ [(x, lbind_typ TX)] ++ D1M) as D1.
  remember (D2L ++ D2M) as D2.
  remember (D3L ++ [(x, lbind_typ TX)] ++ D3M) as D3.
  generalize dependent D1M. generalize dependent D1L.
  generalize dependent D2M. generalize dependent D2L.
  generalize dependent D3M. generalize dependent D3L.
  induction S3; intros D3L D3M EQ3 D2L D2M EQ2 D1L SL D1M SM EQ1; simpl_env in *.
  Case "empty".
    destruct D3L; destruct D3M; inversion EQ3.
  Case "left".
    subst.
    destruct D1L; inversion EQ1; subst; simpl_env in *.
    destruct D3L; inversion EQ3; subst; simpl_env in *.
    inversion SL. subst.
    simpl_env in *.
    rewrite_env (D1M ++ [(x, lbind_typ TX)] ++ nil).
    rewrite_env (D2M ++ nil).
    rewrite_env (D3M ++ [(x, lbind_typ TX)] ++ nil).
    apply lenv_split_weakening_left. simpl_env. auto. auto. auto.
    eapply wf_lenv_lin_weakening. auto. simpl_env.
    eapply wf_lenv_split. apply SM. auto. simpl_env. fsetdec.
    assert False. fsetdec. tauto.
    destruct D3L; inversion EQ3; subst; simpl_env in *.
    rewrite (dom_lenv_split E (D1L ++ [(x, lbind_typ TX)] ++ D1M) (D2L ++ D2M) D3M) in H0.
    simpl_env in H0. assert False. fsetdec. tauto.
    auto.
    apply lenv_split_left; auto. eapply IHS3; auto.
    inversion SL; auto. subst.
    rewrite (dom_lenv_split E ([(x0, lbind_typ T)] ++ D1L) D2 D3L) in H10; auto.
    simpl in H10. assert False. fsetdec. tauto.
  Case "right".
    destruct D2L; inversion EQ2; subst; simpl_env in *.
    destruct D3L; inversion EQ3; subst; simpl_env in *.
    rewrite (dom_lenv_split E D1M ([(x, lbind_typ TX)] ++ D2) D3M) in H0.
    simpl in H0. assert False. fsetdec. tauto.
    rewrite (dom_lenv_split E (D1L ++ [(x, lbind_typ TX)] ++ D1M) D2 D3M) in H0.
    simpl in H0. assert False. rewrite dom_app in H0. simpl in H0. fsetdec. tauto.
    auto.
    rewrite (dom_lenv_split E D1M ([(x0, lbind_typ T)] ++ D2) D3M) in H0.
    simpl in H0. assert False. fsetdec. tauto. auto.
    destruct D3L; inversion EQ3; subst; simpl_env in *.
    inversion SL.
    apply lenv_split_right; auto. eapply IHS3; auto.
    inversion SL; auto. subst.
    rewrite (dom_lenv_split E D1 ([(x0, lbind_typ T)] ++ D2L) D3L) in H10.
    simpl in H10. assert False. fsetdec. tauto. auto.
Qed.

Lemma lenv_split_join: forall E D1 D2 D3 F1 F2 F3,
  lenv_split E D1 D2 D3 ->
  lenv_split E F1 F2 F3 ->
  wf_lenv E (D3 ++ F3) ->
  lenv_split E (D1 ++ F1) (D2 ++ F2) (D3 ++ F3).
Proof.
  intros E D1 D2 D3 F1 F2 F3 S1.
  induction S1; intros S2 WFL; auto.
  Case "left".
    simpl_env in *.
    apply lenv_split_left; auto. apply IHS1; auto.
    inversion WFL; auto. inversion WFL; auto.
  Case "right".
    simpl_env in *.
    apply lenv_split_right; auto. apply IHS1; auto.
    inversion WFL; auto. inversion WFL; auto.
Qed.

Lemma wf_lenv_exchange: forall E x TX DL DR,
  wf_lenv E ([(x, lbind_typ TX)] ++ DL ++ DR) ->
  wf_lenv E (DL ++ [(x, lbind_typ TX)] ++ DR).
Proof.
  intros.
  inversion H.
  apply wf_lenv_lin_weakening; auto.
Qed.

Lemma wf_lenv_exchange_mid: forall E x TX DL DM DR,
  wf_lenv E (DL ++ [(x, lbind_typ TX)] ++ DM ++ DR) ->
  wf_lenv E (DL ++ DM ++ [(x, lbind_typ TX)] ++ DR).
Proof.
  induction DL; intros.
  simpl_env in *. apply wf_lenv_exchange; auto.
  simpl_env in *.
  destruct a. simpl_env in *.
  inversion H.
  apply wf_lenv_typ. apply IHDL; auto. auto.
  repeat rewrite dom_app in *. simpl in *.
  rewrite dom_app in H6. fsetdec.
  auto.
Qed.

Lemma wf_lenv_from_lenv_split_left: forall E D1 D2 DL DR,
  lenv_split E D1 D2 (DL ++ DR) ->
  wf_lenv E DL.
Proof.
  intros. eapply wf_lenv_lin_strengthening.
  rewrite_env (nil ++ DL ++ DR) in H.
  eapply wf_lenv_split. apply H.
Qed.

Lemma wf_lenv_from_lenv_split_right: forall E D1 D2 DL DR,
  lenv_split E D1 D2 (DL ++ DR) ->
  wf_lenv E DR.
Proof.
  intros. eapply wf_lenv_lin_strengthening.
  rewrite_env (DL ++ DR ++ nil) in H.
  eapply wf_lenv_split. apply H.
Qed.

Lemma typing_exchange: forall E D1 D2 D3 x TX e T,
  typing E (D1 ++ [(x, lbind_typ TX)] ++ D2 ++ D3) e T ->
  typing E (D1 ++ D2 ++ [(x, lbind_typ TX)] ++ D3) e T.
Proof.
  intros E D1 D2 D3 x TX e T TYP.
  remember (D1 ++ [(x, lbind_typ TX)] ++ D2 ++ D3) as D.
  generalize dependent D3. generalize dependent D2. generalize dependent D1.
  induction TYP; intros DL DM DR EQ; eauto.
  Case "var".
    destruct DL; simpl in EQ; inversion EQ.
  Case "lvar".
    destruct DL; simpl in EQ; inversion EQ; subst.
    destruct DM; simpl in EQ; inversion EQ; subst.
    simpl_env in *. apply typing_lvar. auto.
    destruct DL; simpl in EQ; inversion EQ.
  Case "abs".
    pick fresh y and apply typing_abs.
    auto.
    rewrite_env (([(y, lbind_typ T1)] ++ DL) ++ DM ++ [(x, lbind_typ TX)] ++ DR).
    apply (H1 y); auto.
    subst. simpl_env. auto.
  Case "app".
    subst.
    lapply (lenv_split_cases_mid E D1 D2 DL x TX (DM ++ DR)); auto.
    intros CASES.
    destruct CASES as [LEFT | RIGHT].
    destruct LEFT as [D1L [D1R [D2L [D2R [EQ1 [EQ2 [S1 S2]]]]]]].
    subst.
    lapply (lenv_split_cases_app E DM D1R D2R DR); auto.
    intros EX.
    destruct EX as [D1RM [D1RR [D2RM [D2RR [S3 [S4 [EQ1 EQ2]]]]]]].
    lapply (IHTYP1 D1L D1RM D1RR); auto.
    intros TYPE1.
    assert (lenv_split E (D1L ++ D1RM ++ [(x, lbind_typ TX)] ++ D1RR)
                         (D2L ++ D2RM ++ D2RR)
                         (DL  ++ DM ++ [(x, lbind_typ TX)] ++ DR)).
    apply lenv_split_join. auto.
    apply lenv_split_weakening_left. subst; auto. auto. auto.
    apply wf_lenv_exchange.
    eapply wf_lenv_from_lenv_split_right. apply H.
    apply wf_lenv_exchange_mid.
    eapply wf_lenv_split. apply H.
    apply (typing_app T1 E
            (D1L ++ D1RM ++ [(x, lbind_typ TX)] ++ D1RR)
            (D2L ++ D2RM ++ D2RR)
            (DL ++ DM ++ [(x, lbind_typ TX)] ++ DR)); auto.
    subst; auto. subst; auto.

    destruct RIGHT as [D1L [D1R [D2L [D2R [EQ1 [EQ2 [S1 S2]]]]]]].
    subst.
    lapply (lenv_split_cases_app E DM D1R D2R DR); auto.
    intros EX.
    destruct EX as [D1RM [D1RR [D2RM [D2RR [S3 [S4 [EQ1 EQ2]]]]]]].
    lapply (IHTYP2 D2L D2RM D2RR); auto.
    intros TYPE2.
    assert (lenv_split E (D1L ++ D1RM ++ D1RR)
                         (D2L ++ D2RM ++ [(x, lbind_typ TX)] ++ D2RR)
                         (DL  ++ DM ++ [(x, lbind_typ TX)] ++ DR)).
    apply lenv_split_join; auto.
    apply lenv_split_weakening_right; subst; auto.
    apply wf_lenv_exchange.
    eapply wf_lenv_from_lenv_split_right. apply H.
    apply wf_lenv_exchange_mid.
    eapply wf_lenv_split. apply H.
    apply (typing_app T1 E
            (D1L ++ D1RM ++ D1RR)
            (D2L ++ D2RM ++ [(x, lbind_typ TX)] ++ D2RR)
            (DL ++ DM ++ [(x, lbind_typ TX)] ++ DR)); auto.
    subst; auto. subst; auto.

  Case "tabs".
    pick fresh X and apply typing_tabs; auto.

  Case "bang".
    contradict EQ. apply nil_neq_one_mid; auto.

  Case "let".
    subst.
    lapply (lenv_split_cases_mid E D1 D2 DL x TX (DM ++ DR)); auto.
    intros CASES.
    destruct CASES as [LEFT | RIGHT].
    destruct LEFT as [D1L [D1R [D2L [D2R [EQ1 [EQ2 [S1 S2]]]]]]].
    subst.
    lapply (lenv_split_cases_app E DM D1R D2R DR); auto.
    intros EX.
    destruct EX as [D1RM [D1RR [D2RM [D2RR [S3 [S4 [EQ1 EQ2]]]]]]]; subst.
    lapply (IHTYP D1L D1RM D1RR); auto.
    intros TYPE1.
    assert (lenv_split E (D1L ++ D1RM ++ [(x, lbind_typ TX)] ++ D1RR)
                         (D2L ++ D2RM ++ D2RR)
                         (DL  ++ DM ++ [(x, lbind_typ TX)] ++ DR)).
      apply lenv_split_join; auto.
        apply lenv_split_weakening_left; subst; auto.
          apply wf_lenv_exchange.
          apply wf_lenv_from_lenv_split_right in H1; auto.
        apply wf_lenv_exchange_mid.
        eapply wf_lenv_split in H1; auto.
    apply typing_let with (L:=L)(D1:=(D1L ++ D1RM ++ [(x, lbind_typ TX)] ++ D1RR))(D2:=(D2L ++ D2RM ++ D2RR))(T1:=T1); auto.

    destruct RIGHT as [D1L [D1R [D2L [D2R [EQ1 [EQ2 [S1 S2]]]]]]].
    subst.
    lapply (lenv_split_cases_app E DM D1R D2R DR); auto.
    intros EX.
    destruct EX as [D1RM [D1RR [D2RM [D2RR [S3 [S4 [EQ1 EQ2]]]]]]]; subst.
    assert (lenv_split E (D1L ++ D1RM ++ D1RR)
                         (D2L ++ D2RM ++ [(x, lbind_typ TX)] ++ D2RR)
                         (DL  ++ DM ++ [(x, lbind_typ TX)] ++ DR)).
      apply lenv_split_join; auto.
        apply lenv_split_weakening_right; subst; auto.
          apply wf_lenv_exchange.
          eapply wf_lenv_from_lenv_split_right in H1; auto.
       apply wf_lenv_exchange_mid.
       eapply wf_lenv_split in H1; auto.
    apply typing_let with (L:=L)(D1:=(D1L ++ D1RM ++ D1RR))(D2:=(D2L ++ D2RM ++ [(x, lbind_typ TX)] ++ D2RR))(T1:=T1); auto.
Qed.

(*
Lemma exchange: forall E D1 D2 e T,
  typing E (D1 ++ D2) e T ->
  typing E (D2 ++ D1) e T.
Proof.
  intros E D1 D2 e T Typ.
  remember (D1 ++ D2) as D.
  generalize dependent D2. generalize dependent D1.
  induction Typ; intros DL DR EQ.
  Case "var".
    destruct DL; destruct DR; inversion EQ; subst; simpl_env in *.
    apply typing_var; auto.
  Case "lvar".
    destruct DL; destruct DR; inversion EQ; subst; simpl_env in *.
    apply typing_lvar; auto.
    subst DL. simpl_env. apply typing_lvar; auto.
    destruct DL; inversion H2.
  Case "abs".
    pick fresh x and apply typing_abs.
    auto. apply (H1 x); auto. intros. subst.
    lapply H2; auto; intros.
    destruct DL; destruct DR; inversion H3. simpl_env. auto.
  Case "labs".
    pick fresh x and apply typing_labs.
    auto. rewrite_env (([(x, lbind_typ T1)] ++ DR) ++ DL).
    apply (H1 x); auto.

*)

(*
This lemma is false:

Lemma lenv_split_cases_left_tail: forall E DL D1 D2 DR,
  lenv_split E D1 D2 (DL ++ DR) ->
  exists D1L, exists D1R, exists D2L, exists D2R,
    lenv_split E D1L D1R DL /\
    lenv_split E D2L D2R DR /\
    D1L ++ D1R = D1 /\
    D2L ++ D2R = D2.

Counterexample: let DL = lempty and pick D1 <> lempty
  then D1L = D1R = lempty but D1L ++ D1R = lempty <> D1
*)

(* This lemma is false:
Lemma lenv_splice: forall E DL DR DX D1 D2,
  lenv_split E D1 D2 (DL ++ DR) ->
  lenv_split E DL DR DX ->
  lenv_split E D1 D2 DX.
Proof.
Counterexample:
[x y] U [z w] =  [x z] ++ [y w]
[x z] U [y w] =  [y x] ++ [w z]
[x y] U [z w] <> [y x] ++ [w z]
*)

Lemma lenv_split_cases_left_tail: forall E D1 D2 D3 x T,
  lenv_split E ([(x, lbind_typ T)] ++ D1) D2 D3 ->
  exists DL, exists D2R, exists D3R,
    D2 = DL ++ D2R /\
    D3 = DL ++ [(x, lbind_typ T)] ++ D3R /\
    lenv_split E D1 D2R D3R.
Proof.
  intros E D1 D2 D3 x T S.
  remember ([(x, lbind_typ T)] ++ D1) as D0.
  generalize dependent D1.
  induction S; intros D1R EQ; simpl_env in *.
  Case "empty".
    inversion EQ.
  Case "left".
    inversion EQ; subst.
    exists lempty. exists D2. exists D3.
    simpl_env in *. repeat split; auto.
  Case "right".
    lapply (IHS D1R); intros; auto.
    destruct H2 as [DL [D2R [D3R [Q1 [Q2 S2]]]]].
    exists ([(x0, lbind_typ T0)] ++ DL).
    exists D2R.
    exists D3R.
    subst. simpl_env in *. repeat split; auto.
Qed.

Lemma lenv_split_cases_right_tail: forall E D1 D2 D3 x T,
  lenv_split E D1 ([(x, lbind_typ T)] ++ D2) D3 ->
  exists DL, exists D1R, exists D3R,
    D1 = DL ++ D1R /\
    D3 = DL ++ [(x, lbind_typ T)] ++ D3R /\
    lenv_split E D1R D2 D3R.
Proof.
  intros.
  lapply (lenv_split_cases_left_tail E D2 D1 D3 x T).
  intros.
  destruct H0 as [DL [D2R [D3R [Q1 [Q2 S2]]]]].
  exists DL. exists D2R. exists D3R.
  repeat split; auto.
  apply lenv_split_commute; auto.
  apply lenv_split_commute; auto.
Qed.

Lemma wf_env_weakening: forall E F G,
  wf_env (G ++ E) ->
  wf_env (F ++ E) ->
  uniq (G ++ F ++ E) ->
  wf_env (G ++ F ++ E).
Proof.
  intros E F G.
  generalize dependent F.
  induction G; intros F H1 H2 Uniq.
  Case "empty".
    simpl_env. auto.
  rewrite_env ([a] ++ (G ++ E)) in H1.
  rewrite_env ([a] ++ (G ++ F ++ E)).
  rewrite_env ([a] ++ (G ++ F ++ E)) in Uniq.
  inversion H1.
  Case "kn".
    apply wf_env_kn. apply IHG. auto. auto. eapply uniq_app_2.
    eauto. subst. inversion Uniq. auto.
  Case "typ".
    eapply wf_env_typ. apply IHG; auto. eapply uniq_app_2.
    eauto. eapply wf_typ_weakening. eapply H4.
    eapply uniq_app_2. eauto. subst. inversion Uniq. auto.
Qed.

Lemma wf_env_weakening_tail: forall E F,
  wf_env E ->
  wf_env F ->
  uniq (F ++ E) ->
  wf_env (F ++ E).
Proof.
  intros E F.
  generalize dependent E.
  induction F; intros E WF1 WF2 Uniq.
  simpl. auto.
  inversion WF2.
  rewrite_env ([(X, bind_kn)] ++ F ++ E).
  eapply wf_env_kn. apply IHF; auto. rewrite_env ([a] ++ (F ++ E)) in Uniq. eapply uniq_app_2. eapply Uniq. subst a.
  inversion Uniq.  auto.
  rewrite_env ([(x, bind_typ T)] ++ F ++ E).
  eapply wf_env_typ. apply IHF; auto. rewrite_env ([a] ++ (F ++ E)) in Uniq. eapply uniq_app_2. eapply Uniq.
  rewrite_env (F ++ E ++ nil). apply wf_typ_weakening. rewrite <- app_nil_end. eapply H2.
  rewrite <- app_nil_end. rewrite_env ([a] ++ (F ++ E)) in Uniq. eapply uniq_app_2. eapply Uniq.
  subst a. inversion Uniq.  auto.
Qed.

Lemma open_kn: forall L E T,
  (forall (Y: atom), Y `notin` L -> wf_typ ([(Y, bind_kn)] ++ E) (open_tt T Y)) ->
  wf_typ E (typ_all T).
Proof.
  intros L E T H.
  induction T; pick fresh Z and apply wf_typ_all;
    try solve [apply (H Z); auto].
Qed.

Lemma wf_typ_from_wf_lenv: forall x T E D1 D2,
  wf_lenv E (D1 ++ [(x, lbind_typ T)] ++ D2) ->
  wf_typ E T.
Proof.
  intros x T E D1 D2 WFL.
  remember (D1 ++ [(x, lbind_typ T)] ++ D2) as D.
  generalize dependent D1.
  induction WFL; intros D1 EQ.
     assert False. eapply nil_eq_one_mid_false. eapply EQ. tauto.
  destruct D1; inversion EQ; subst.
    auto.
  apply (IHWFL D1); auto.
Qed.

(*
*** Local Variables: ***
*** coq-prog-name: "coqtop" ***
*** coq-prog-args: ("-emacs-U" "-I" "../../../metatheory") ***
*** End: ***
 *)


(* PUBLIC DOMAIN *)
(* Author: Georgy Dunaev, georgedunaev@gmail.com *)
Require Export Coq.Vectors.Vector.
Require Export Coq.Lists.List.
Require Import Bool.Bool.
Require Import Logic.FunctionalExtensionality.
Require Import Coq.Program.Wf.
Require Import Lia.
Add LoadPath "/home/user/0my/COQ".
Require Export UNIV_INST.

Inductive myeq (A : Type) (x : A) : A -> Type :=
| myeq_refl : myeq A x x.

Fixpoint myvec_comp_as {A B C} (f:B->C) (g:A->B) (n:nat) (t0: Vector.t A n) :
myeq _ (Vector.map f (Vector.map g t0))
(Vector.map (fun x=>(f(g x))) t0).
Proof.
destruct t0.
simpl.
reflexivity.
simpl.
rewrite -> myvec_comp_as.
reflexivity.
Defined.

Fixpoint vec_comp_as {A B C} (f:B->C) (g:A->B) (n:nat) (t0: Vector.t A n) :
Vector.map f (Vector.map g t0) =
Vector.map (fun x=>(f(g x))) t0.
Proof.
destruct t0.
simpl.
reflexivity.
simpl.
rewrite -> vec_comp_as.
reflexivity.
Defined.

Module VS.
Section sec0.
Definition SetVars  := nat.
Definition FuncSymb := nat.
Definition PredSymb := nat.
Record FSV := {
 fs : FuncSymb;
 fsv : nat;
}.
Record PSV := MPSV{
 ps : PredSymb;
 psv : nat;
}.
Check MPSV 0 0.
Notation A1Type:=Set.
Unset Elimination Schemes.
Inductive Terms : A1Type :=
| FVC :> SetVars -> Terms
| FSC (f:FSV) : (Vector.t Terms (fsv f)) -> Terms.
Set Elimination Schemes.

Definition Terms_rect (T : Terms -> Type)
                      (H_FVC : forall sv, T (FVC sv))
                      (H_FSC : forall f v, (forall n, T (Vector.nth v n)) -> T (FSC f v)) :=
  fix loopt (t : Terms) : T t :=
    match t with
    | FVC sv  => H_FVC sv
    | FSC f v =>
      let fix loopv s (v : Vector.t Terms s) : forall n, T (Vector.nth v n) :=
        match v with
        | @Vector.nil _ => Fin.case0 _
        | @Vector.cons _ t _ v => fun n => Fin.caseS' n (fun n => T (Vector.nth (Vector.cons _ t _ v) n))
                                                      (loopt t)
                                                      (loopv _ v)
        end in
      H_FSC f v (loopv _ v)
    end.

Definition Terms_ind (T : Terms -> Prop)
                      (H_FVC : forall sv, T (FVC sv))
                      (H_FSC : forall f v, (forall n, T (Vector.nth v n)) -> T (FSC f v)) :=
  fix loopt (t : Terms) : T t :=
    match t with
    | FVC sv  => H_FVC sv
    | FSC f v =>
      let fix loopv s (v : Vector.t Terms s) : forall n, T (Vector.nth v n) :=
        match v with
        | @Vector.nil _ => Fin.case0 _
        | @Vector.cons _ t _ v => fun n => Fin.caseS' n (fun n => T (Vector.nth (Vector.cons _ t _ v) n))
                                                      (loopt t)
                                                      (loopv _ v)
        end in
      H_FSC f v (loopv _ v)
    end.

(*Formulas*)
(*Unset Elimination Schemes.*)
Inductive Fo :=
|Atom (p:PSV) : (Vector.t Terms (psv p)) ->  Fo
|Bot :Fo
|Conj:Fo->Fo->Fo
|Disj:Fo->Fo->Fo
|Impl:Fo->Fo->Fo
|Fora(x:SetVars)(f:Fo): Fo
|Exis(x:SetVars)(f:Fo): Fo
.
(*Set Elimination Schemes.
Section Fo_rect_section.
Definition Fo_rect (T : Fo -> Type)
                      (H_FVC : forall sv, T (FVC sv))
                      (H_FSC : forall f v, (forall n, T (Vector.nth v n)) -> T (FSC f v)) :=
  fix loopt (t : Terms) : T t :=
    match t with
    | FVC sv  => H_FVC sv
    | FSC f v =>
      let fix loopv s (v : Vector.t Terms s) : forall n, T (Vector.nth v n) :=
        match v with
        | @Vector.nil _ => Fin.case0 _
        | @Vector.cons _ t _ v => fun n => Fin.caseS' n (fun n => T (Vector.nth (Vector.cons _ t _ v) n))
                                                      (loopt t)
                                                      (loopv _ v)
        end in
      H_FSC f v (loopv _ v)
    end.
End Fo_rect_section.*)

(* Substitution *)

Fixpoint substT (t:Terms) (xi: SetVars) (u:Terms): Terms.
Proof.
destruct u.
2 : { refine (FSC _ _).
Check @Vector.map.
Check @Vector.map _ _ (substT t xi) _ t0.
exact ( @Vector.map _ _ (substT t xi) _ t0 ). }

{
(*Check my.beq_natP s xi.*)
destruct (PeanoNat.Nat.eqb s xi).
Print bool.
exact t.
exact s. }
(*Show Proof.*)
Defined.

Fixpoint isParamT (xi : SetVars) (t : Terms) {struct t} : bool :=
   match t with
   | FVC s => PeanoNat.Nat.eqb s xi
   | FSC f t0 => Vector.fold_left orb false (Vector.map (isParamT xi) t0)
   end.

Fixpoint isParamF (xi:SetVars) (f:Fo): bool.
Proof.
(*elim f; intros. *)
destruct f.
Show Proof.
Search "Exists".
exact (Vector.fold_left orb false (Vector.map (isParamT xi) t)).
exact false.
Show Proof.
exact (orb (isParamF xi f1) (isParamF xi f2)).
exact (orb (isParamF xi f1) (isParamF xi f2)).
exact (orb (isParamF xi f1) (isParamF xi f2)).
Show Proof.
exact (match (PeanoNat.Nat.eqb x xi) with
       | true => false
       | false => (isParamF xi f)
       end).
exact (match (PeanoNat.Nat.eqb x xi) with
       | true => false
       | false => (isParamF xi f)
       end).
Show Proof.
Defined.

Fixpoint substF (t:Terms) (xi: SetVars) (u : Fo): option Fo.
Proof.
pose(g := substT t xi).
pose(f := substF t xi).
destruct u.
refine (Some (Atom p _)).
exact (Vector.map g t0).
exact (Some Bot).
 exact (
 match (f u1),(f u2) with
 | Some f0,Some f1 => (Some (Conj f0 f1))
 | _,_ => None
 end).
 exact (
 match (f u1),(f u2) with
 | Some f0,Some f1 => (Some (Disj f0 f1))
 | _,_ => None
 end).
 exact (
 match (f u1),(f u2) with
 | Some f0,Some f1 => (Some (Impl f0 f1))
 | _,_ => None
 end).
(*destruct (isParamF xi (Fora x0 u)).*)
refine (match (isParamF xi (Fora x u)) with
| true => match (isParamT x t) with
          | false => match substF t xi u with
                    | Some q => Some (Fora x q)
                    | None => None
                    end
          | true => None
          end
| false => Some (Fora x u) end).
refine (match (isParamF xi (Exis x u)) with
| true => match (isParamT x t) with
          | false => match substF t xi u with
                    | Some q => Some (Exis x q)
                    | None => None
                    end
          | true => None
          end
| false => Some (Exis x u) end).
Defined.

Definition Top:Fo := Impl Bot Bot.

Notation " x --> y ":=(Impl x y) (at level 80).
(*
Notation " u '[' t >> xi ] ":=(substT t xi u ) (at level 10).
Set Warnings "-notation-overridden".
Notation " ph [ t | xi ] ":=(substF t xi ph ) (at level 10).
(*Set Warnings "default".*)
Check fun (t:Terms) (x:SetVars) => ( t [ t >> x ]).
Check fun (t:Terms) (x:SetVars) (ph:Fo) => ( ph [ t | x ] ).
*)

Open Scope list_scope.
Print List.In.
Locate "+".
Print sum.
Definition InL { A : Type } :=
fix InL (a : A) (l : list A) {struct l} : Type :=
  match l with
  | Datatypes.nil => False
  | b :: m => (sum (b = a) (InL a m))
  end.

Inductive PR (axi:list Fo) : Fo -> Type :=
| hyp (A : Fo): (InL A axi)-> @PR axi A
| a1 (A B: Fo) : @PR axi (Impl A (Impl B A))
| a2 (A B C: Fo) : @PR axi ((A-->(B-->C))-->((A-->B)-->(A-->C)))
| a12 (ph: Fo) (t:Terms) (xi:SetVars)
: @PR axi (match (substF t xi ph) with
      | Some q => (Impl (Fora xi ph) q)
      | None => Top
      end)
| b1 (ps ph: Fo) (xi:SetVars) (H:isParamF xi ps = false):
@PR axi (Impl (Fora xi (Impl ps ph)) (Impl ps (Fora xi ph)) )
| MP (A B: Fo) : (@PR axi A)->(@PR axi (Impl A B))->(@PR axi B)
| GEN (A : Fo) (xi:SetVars): (@PR axi A)->(@PR axi (Fora xi A))
.

Check @PR.
Definition AtoA (A:Fo) : PR (List.nil) (A-->A).
Proof.
apply (MP nil (A-->(A-->A)) _).
apply a1.
apply (MP nil (A-->((A-->A)-->A)) _).
apply a1.
apply a2.
Defined.

Definition B1 (ps ph:Fo) (xi:SetVars) (H:isParamF xi ps = false):
 PR nil (ps --> ph) -> PR nil (ps --> Fora xi ph).
Proof.
intro q.
apply (MP nil (Fora xi (ps --> ph))).
+ apply GEN.
  exact q.
+ apply (b1 _).
  exact H.
Defined.

Definition gen (A:Fo) (xi:SetVars) (*Generalization from Bernay's rule*)
: PR nil (A) -> PR nil (Fora xi A).
Proof.
intro q.
apply (MP nil Top).
unfold Top.
exact (AtoA Bot).
apply (MP nil (Fora xi (Top --> A))).
* apply GEN.
  apply (MP nil A).
  + exact q.
  + apply a1.
* apply b1.
  trivial.
Defined.

Definition neg (f:Fo):= (Impl f Bot).

Definition a1i (A B : Fo)(l : list Fo):(PR l B)->(PR l (Impl A B)).
Proof.
intros x.
apply (MP l B).
exact x.
apply a1.
Defined.

Fixpoint weak (A F:Fo) (l :list Fo) (x: (PR l F)) : (PR (A::l) F).
Proof.
destruct x.
apply hyp.
apply inr. (*or_intror *)
exact i.
apply a1.
apply a2.
apply a12.
apply b1.
assumption.
apply (@MP _ A0).
apply weak.
exact x1.
apply weak.
exact x2.
apply GEN. (* Order is not important! *)
apply weak. (* Order is not important! *)
exact x.
Defined.

Fixpoint weaken (F:Fo) (li l :list Fo) (x: (PR l F)) {struct li}: (PR (li ++ l) F).
Proof.
destruct li.
simpl.
exact x.
simpl.
simple refine (@weak f F (li ++ l) _).
apply weaken.
exact x.
Defined.

(*Export List Notations.*)
Fixpoint notGenWith (xi:SetVars)(l:list Fo)(B:Fo)(m:(PR l B)){struct m}:bool.
Proof.
destruct m.
exact true.
exact true.
exact true.
exact true.
exact true.
exact (andb (notGenWith xi l _ m1) (notGenWith xi l _ m2)).
exact (andb (negb (PeanoNat.Nat.eqb xi xi0)) (notGenWith xi l _ m) ).
Defined.
Check isParamF.
(*Check fun A B=> forall xi:SetVars, (true = isParamF xi A)->(notGenWith xi m).*)
Fixpoint HA xi : true = PeanoNat.Nat.eqb (xi) (xi).
Proof.
destruct xi.
reflexivity.
simpl.
exact (HA xi).
Defined.

Fixpoint ZX (xi:SetVars) :true = negb (PeanoNat.Nat.eqb xi xi) -> False.
Proof.
intro q.
destruct xi.
compute in q.
inversion q.
rewrite <- HA in q.
inversion q.
Defined.

Theorem lm (a b :bool)(G:true = (a && b) ): true = a.
Proof.
destruct a.
trivial.
inversion G.
Defined.

Theorem lm2 (a b :bool)(G:true = (a && b) ): true = b.
Proof.
destruct a.
trivial.
inversion G.
Defined.

Theorem N (rr:bool): (true=rr \/ rr=false).
Proof.
destruct rr; firstorder.
Defined.

Fixpoint Ded (A B:Fo)(il:list Fo)(m:(PR (cons A il) B))
(H:forall xi:SetVars, (true = isParamF xi A)->(true=notGenWith xi _ _ m))
{struct m}:(PR il (A-->B)).
Proof.
destruct m. (*as [i|i|i|i|i|i|i].*)
+ unfold In in i.
  simpl in i .
  destruct i .
  * rewrite <- e.
    pose (J:=weaken _ il nil (AtoA A )).
    rewrite app_nil_r in J.
    exact J.
(*exact (weaken _ il nil (AtoA A )).
apply weak.
exact (AtoA A ).
exfalso.*)
  * simpl in H.
    apply a1i.
    exact (hyp il _ i).
+ apply a1i.
  apply a1.
+ apply a1i.
  apply a2.
+ apply a1i.
  apply a12.
+ apply a1i.
  apply b1.
  trivial.
+ apply (MP _ (A-->A0)).
- simple refine (@Ded _ _ _ _ _).
  exact m1.
  intros xi H0.
  pose (W:=H xi H0).
  simpl in W.
  pose (J:=notGenWith xi (A :: il) A0 m1).
  try reflexivity.
  fold J.
  fold J in W.
  apply (lm _ _ W).
-
apply (MP _ (A-->(A0-->B))).
simple refine (@Ded _ _ _ _ _).
  exact m2.
  intros xi H0.
  pose (W:=H xi H0).
  simpl in W.
  apply (lm2 _ _ W).
(*Last part about GEN*)
apply a2.
+
apply (MP _ (Fora xi (A-->A0))).
apply GEN.
simple refine (@Ded _ _ _ _ _).
  exact m.
  intros xi0 H0.
  pose (W:=H xi0 H0).
  simpl in W.
* exact (lm2 _ _ W).
* simpl.
apply b1.
pose (r := isParamF xi A).
pose (U := H xi).
fold r in U |- *.
simpl in U.

destruct (N r).
pose (C:= lm _ _(U H0)).
exfalso.
exact (ZX _ C).
exact H0.
Show Proof.
Defined.

(*Fixpoint Ded (A B:Fo)(m:(PR (cons A nil) B)) *)

Definition lm3 (a b :bool)(A: true = a)(B: true = b):true = (a && b)
:=
 (if a as a0 return (true = a0 -> true = a0 && b)
  then
   fun _ : true = true =>
   (if b as b0 return (true = b0 -> true = true && b0)
    then fun _ : true = true => eq_refl
    else fun B0 : true = false => B0) B
  else
   fun A0 : true = false =>
   (if b as b0 return (true = b0 -> true = false && b0)
    then fun _ : true = true => A0
    else fun _ : true = false => A0) B) A.
(*destruct a,b.
reflexivity.
simpl.
exact B.
simpl.
exact A.
simpl.
exact A.
Show Proof.
Defined.*)

Fixpoint forClosed (A B:Fo)(m:(PR (cons A nil) B)):
(forall xi:SetVars, (false = isParamF xi A))
->
(forall xi:SetVars, (true = isParamF xi A)->(true=notGenWith xi _ _ m)).
Proof.
intros H xi Q.
destruct m; simpl; try reflexivity.
+ apply lm3.
  simple refine (@forClosed _ _ _ _ _ _); assumption.
  simple refine (@forClosed _ _ _ _ _ _); assumption.
+ apply lm3.
  2 : simple refine (@forClosed _ _ _ _ _ _); assumption.
  pose (U:=H xi).
  rewrite <- Q in U.
  exfalso.
  inversion U.
Show Proof.
Defined.

Fixpoint SimplDed (A B:Fo) (il: list Fo)(m:(PR (cons A il) B))
(NP:forall xi:SetVars, (false = isParamF xi A))
{struct m}:(PR il (A-->B)).
Proof.
simple refine (Ded _ _ _ _ _).
exact m.
intros xi H.
rewrite <- NP in H.
inversion H.
Defined.
End sec0.

Module ModProp.
Definition Omega := Prop.
Definition OFalse := False.
Definition OAnd := and.
Definition OOr := or.
Definition OImp := (fun x y:Omega => x->y).
End ModProp.

Module ModBool.
Definition Omega := bool.
Definition OFalse := false.
Definition OAnd := andb.
Definition OOr := orb.
Definition OImp := implb.
End ModBool.

(* Here we choose an interpretation. *)
(*Export ModBool.*)
Export ModProp. (* + classical axioms *)

(** Correctness theorem **)
(** for two-valued logic **)
Section cor.
 (* Truth values*)
Context (X:Type).
(*Context (val:SetVars->X).*)
Context (fsI:forall(q:FSV),(Vector.t X (fsv q))->X).
Context (prI:forall(q:PSV),(Vector.t X (psv q))->Omega).
(*Context (prI:forall(q:PSV),(Vector.t X (psv q))->Prop).*)

Fixpoint teI (val:SetVars->X) (t:Terms): X.
Proof.
destruct t.
exact (val s).
refine (fsI f _).
simple refine (@Vector.map _ _ _ _ _).
2 : apply teI.
exact val.
exact t.
Show Proof.
Defined.
(*
Fixpoint foI (val:SetVars->X) (f:Fo): Omega.
Proof.
destruct f.
+ refine (prI p _).
  apply (Vector.map  (teI val)).
  exact t.
+ exact false.
+ exact ( andb (foI val f1) (foI val f2)).
+ exact (  orb (foI val f1) (foI val f2)).
+ exact (implb (foI val f1) (foI val f2)).
+  (*Infinite conjunction!!!*)
 Show Proof.
*)

(** (\pi + (\xi \mapsto ?) ) **)
Definition cng (val:SetVars -> X) (xi:SetVars) (m:X) :=
(fun r:SetVars =>
match Nat.eqb r xi with
| true => m
| false => (val r)
end).

(*Inductive foI (val:SetVars->X) (f:Fo): Prop
:=
   | cAtom p t0 => ?Goal0@{t:=t0}
.
   | cBot => ?Goal
   | cConj f1 f2 => ?Goal1
   | cDisj f1 f2 => ?Goal2
   | cImpl f1 f2 => ?Goal3
   | cFora x f0 => ?Goal4@{f:=f0}
   | cExis x f0 => ?Goal5@{f:=f0}
.*)

Fixpoint foI (val:SetVars->X) (f:Fo): Omega.
Proof.
destruct f.
Show Proof.
+ refine (prI p _).
  apply (@Vector.map Terms X (teI val)).
  exact t.
+ exact OFalse.
+ exact ( OAnd (foI val f1) (foI val f2)).
+ exact (  OOr (foI val f1) (foI val f2)).
+ exact ( OImp (foI val f1) (foI val f2)).
Show Proof.
+ exact (forall m:X, foI (cng val x m) f).
(*forall m:X, foI (fun r:SetVars =>
match Nat.eqb r x with
| true => m
| false => (val r)
end
) f*)
+ exact (exists m:X, foI (fun r:SetVars =>
match Nat.eqb r x with
| true => m
| false => (val r)
end
) f
).
Defined.

Definition ap {A B}{a0 a1:A} (f:A->B) (h:a0=a1):((f a0)=(f a1))
:= match h in (_ = y) return (f a0 = f y) with
   | eq_refl => eq_refl
   end.

Section Lem1.
(*Context (t : Terms).*)

(* page 136 of the book *)
Definition lem1 (t : Terms) : forall (u :Terms) (xi : SetVars) (pi : SetVars->X) ,
(teI pi (substT t xi u))=(teI (cng pi xi (teI pi t)) u).
Proof.
fix lem1 1.
intros.
induction u as [s|f].
(*destruct u as [s|f] .*)
+ simpl.
  unfold cng.
  destruct (Nat.eqb s xi) eqn:ek. (* fsI as [H1|H2].*)
  * reflexivity.
  * simpl.
    reflexivity.
Show Proof.
+
  simpl. (* fsI teI *)
  destruct f.
  simpl.
  apply ap.
 simpl in * |- *.
apply (*Check *)
(proj1 (
eq_nth_iff X fsv0
(Vector.map (teI pi) (Vector.map (substT t xi) v))
(Vector.map (teI (cng pi xi (teI pi t))) v)
)).
intros.
(*rewrite H0.*)
 simpl in * |- *.
(* now I need to show that .nth and .map commute *)
Check nth_map (teI pi) (Vector.map (substT t xi) v) p1 p2 H0.
rewrite -> (nth_map (teI pi) (Vector.map (substT t xi) v) p1 p2 H0).
Check nth_map (teI (cng pi xi (teI pi t))) v.
rewrite -> (nth_map (teI (cng pi xi (teI pi t))) v p2 p2 ).
Check nth_map (substT t xi) v p2 p2 eq_refl.
rewrite -> (nth_map (substT t xi) v p2 p2 eq_refl).
exact (H p2).
reflexivity.
Defined.

(*Theorem additi pi xi n (v:Vector.t _ n) :
Vector.map (teI pi) (Vector.map (substT t xi) v) =
Vector.map (teI (cng pi xi (teI pi t))) v.
apply (*Check *)
(proj1 (
eq_nth_iff X fsv0
(Vector.map (teI pi) (Vector.map (substT t xi) v))
(Vector.map (teI (cng pi xi (teI pi t))) v)
)).
intros.
(*rewrite H0.*)
 simpl in * |- *.
(* now I need to show that .nth and .map commute *)
Check nth_map (teI pi) (Vector.map (substT t xi) v) p1 p2 H0.
rewrite -> (nth_map (teI pi) (Vector.map (substT t xi) v) p1 p2 H0).
Check nth_map (teI (cng pi xi (teI pi t))) v.
rewrite -> (nth_map (teI (cng pi xi (teI pi t))) v p2 p2 ).
Check nth_map (substT t xi) v p2 p2 eq_refl.
rewrite -> (nth_map (substT t xi) v p2 p2 eq_refl).
exact (H p2).
reflexivity.*)

End Lem1.

Theorem SomeInj {foo} :forall (a b : foo), Some a = Some b -> a = b.
Proof.
  intros a b H.
  inversion H.
  reflexivity.
Defined.

Theorem eq_equ (A B:Prop) : A=B -> (A <-> B).
Proof.
intro p.
destruct p.
firstorder.
Defined. (* rewrite p. firstorder. *)

Theorem conj_eq (A0 B0 A1 B1:Prop)(pA:A0=A1)(pB:B0=B1): (A0 /\ B0) = (A1 /\ B1).
Proof. destruct pA, pB; reflexivity. Defined.
Theorem disj_eq (A0 B0 A1 B1:Prop)(pA:A0=A1)(pB:B0=B1): (A0 \/ B0) = (A1 \/ B1).
Proof. destruct pA, pB; reflexivity. Defined.
Theorem impl_eq (A0 B0 A1 B1:Prop)(pA:A0=A1)(pB:B0=B1): (A0 -> B0) = (A1 -> B1).
Proof. destruct pA, pB; reflexivity. Defined.
Lemma dbl_cng pi xi m1 m2: forall q,(cng (cng pi xi m1) xi m2) q = (cng pi xi m2) q.
Proof. intro q. unfold cng. destruct (Nat.eqb q xi); reflexivity. Defined.

Theorem l01 h n v :
Vector.fold_left orb false (Vector.cons bool h n v) = Vector.fold_left orb (orb false h) v.
Proof.
simpl. reflexivity.
Defined.
(*Fixpoint {struct v}*)
(*fold_left orb true v*)
(*Lemma l00 h n v :  Vector.fold_left orb false (Vector.cons bool h n v) = false
-> (h=false).
intros.
destruct h eqn:y.
simpl in * |- *.
simpl.
auto. *)

(** NOW SEE seq_of_bool.v **)
Check all_then_someV.
(*Lemma all_then_some (A:Type)(n:nat)(p:Fin.t (n)) (v:Vector.t bool (n))
(H : Vector.fold_left orb false v = false)
 : (Vector.nth v p) = false.
Proof.
induction v.
inversion p.
rewrite -> l01 in H.
destruct h.
admit.
simpl in H.
(*pose (G:= IHv (@Fin.F1 n) H).
simpl.
destruct p.*)
Abort.*)

Lemma all_then_someP (A:Type)(n:nat)(p:Fin.t (n)) (v:Vector.t A (n)) (P:A->bool)
(H : Vector.fold_left orb false (Vector.map P v) = false)
 : (P (Vector.nth v p)) = false.
Proof.
Check nth_map P v p p eq_refl.
rewrite <- (nth_map P v p p eq_refl).
apply all_then_someV. trivial.
Defined.

(* Not a parameter then not changed afted substitution (for Terms) *)
Lemma NPthenNCAST (u:Terms)(xi:SetVars)(t:Terms) (H:(isParamT xi u=false))
: (substT t xi u) = u.
Proof. induction u.
+ simpl in * |- *.
  rewrite H. reflexivity.
+ simpl in * |- *.
  apply ap.
apply eq_nth_iff.
intros p1 p2 ppe.
Check nth_map _ _ _ p2 ppe.
rewrite (nth_map _ _ _ p2 ppe).
apply H0.
simpl.
apply all_then_someP.
trivial.
Defined.

Lemma NPthenNCAST_vec:forall p xi t ts (H:(isParamF xi (Atom p ts)=false)),
  (Vector.map (substT t xi) ts) = ts.
Proof.
  intros p xi t1 ts H.
  apply eq_nth_iff.
  intros p1 p2 H0.
  Check nth_map (substT t1 xi) ts p1 p2 H0.
  rewrite -> (nth_map (substT t1 xi) ts p1 p2 H0).
  apply NPthenNCAST.
  apply all_then_someP.
  simpl in H.
  exact H.
Defined.

(* Not a parameter then not changed afted substitution (for Formulas) *)
Fixpoint NPthenNCASF (mu:Fo) : forall (xi:SetVars)(t:Terms) (H:(isParamF xi mu=false))
   , substF t xi mu = Some mu .
Proof. (*induction mu eqn:u0.*)
destruct mu eqn:u0.
Check t.
* intros xi t0 H.
  simpl.
  rewrite -> NPthenNCAST_vec; (trivial || assumption).
* intros xi t H.
  simpl; trivial.
* intros xi t H.
  simpl.
  simpl in H.
  (*pose (Q:=A1 _ _ H).*)
  destruct (A1 _ _ H) as [H0 H1].
  rewrite -> NPthenNCASF .
  rewrite -> NPthenNCASF .
  (*rewrite -> IHf1 with xi t.
  rewrite -> IHf2 with xi t.*)
  trivial.
  trivial.
  trivial.
* simpl.
  intros xi t H.
  destruct (A1 _ _ H) as [H0 H1].
  rewrite -> NPthenNCASF .
  rewrite -> NPthenNCASF .
  (*rewrite -> IHmu1 with xi t.
  rewrite -> IHmu2 with xi t.*)
  trivial.
  trivial.
  trivial.
* simpl.
  intros xi t H.
  destruct (A1 _ _ H) as [H0 H1].
  rewrite -> NPthenNCASF .
  rewrite -> NPthenNCASF .
  trivial.
  trivial.
  trivial.
* simpl.
  intros xi t H.
  destruct (PeanoNat.Nat.eqb x xi) eqn:u2.
  trivial.
  destruct (isParamF xi f) eqn:u1.
  inversion H.
  trivial.
* simpl.
  intros xi t H.
  destruct (PeanoNat.Nat.eqb x xi) eqn:u2.
  trivial.
  destruct (isParamF xi f) eqn:u1.
  inversion H.
  trivial.
Defined.

(* p.137 *)
Section Lem2.
Definition lem2 : forall (t : Terms) (fi : Fo) (xi : SetVars) (pi : SetVars->X),
option_map (foI pi ) (substF t xi fi) = Some (foI (cng pi xi (teI pi t)) fi).
Proof.
fix lem2 1. intros.
destruct (substF t xi fi).
2 : { simpl.
Abort.

Definition lem2 : forall (t : Terms) (fi : Fo) (xi : SetVars) (pi : SetVars->X),
match (substF t xi fi) with
| Some r => (foI pi r)=(foI (cng pi xi (teI pi t)) fi)
| None => True
end.
Proof. fix lem2 1. intros. destruct (substF t xi fi). 2 : exact I.
destruct f eqn:u0.
simpl in * |- *.
Fail  apply
    (proj1 (
      eq_nth_iff X (psv p)
      (Vector.map (teI pi) (Vector.map (substT t xi) t0))
      (Vector.map (teI (cng pi xi (teI pi t))) t0)
    )).
Abort.

Context (t : Terms).
Definition lem2 : forall (fi : Fo) (xi : SetVars) (pi : SetVars->X)
(r:Fo) (H:(substF t xi fi) = Some r), (*(SH:sig (fun(r:Fo)=>(substF t xi fi) = Some r)),*)
(foI pi r)=(foI (cng pi xi (teI pi t)) fi).
Proof.
fix lem2 1.
intros fi xi pi.
(*destruct (substF t xi fi) eqn: j.*)
(**)
induction fi.
+  simpl in *|-*; intros r H.
  pose (Q:=SomeInj _ _ H).
  rewrite <- Q.
  simpl.
  (*apply eq_equ.*)
  apply ap.
  apply
    (proj1 (
      eq_nth_iff X (psv p)
      (Vector.map (teI pi) (Vector.map (substT t xi) t0))
      (Vector.map (teI (cng pi xi (teI pi t))) t0)
    )).
  rename t0 into v.
  intros p1 p2 H0.
  rewrite -> (nth_map (teI pi) (Vector.map (substT t xi) v) p1 p2 H0).
  rewrite -> (nth_map (teI (cng pi xi (teI pi t))) v p2 p2 ).
  rewrite -> (nth_map (substT t xi) v p2 p2 eq_refl).
  apply lem1. reflexivity.
+  simpl in *|-*; intros r H.
   inversion H. trivial.
+  simpl in *|-*; intros r H.
  destruct (substF t xi fi1) as [f1|].
  destruct (substF t xi fi2) as [f2|].
  pose (Q:=SomeInj _ _ H).
  rewrite <- Q.
  apply conj_eq ;   fold foI.
  simpl in * |- *.
  * apply (IHfi1 f1 eq_refl).
  * apply (IHfi2 f2 eq_refl).
  * inversion H.
  * inversion H.
+ simpl in *|-*; intros r H.
  destruct (substF t xi fi1) as [f1|].
  destruct (substF t xi fi2) as [f2|].
  pose (Q:=SomeInj _ _ H).
  rewrite <- Q.
  simpl in * |- *.
  apply disj_eq ;   fold foI.
  * apply (IHfi1 f1 eq_refl).
  * apply (IHfi2 f2 eq_refl).
  * inversion H.
  * inversion H.
+ simpl in *|-*; intros r H.
  destruct (substF t xi fi1) as [f1|].
  destruct (substF t xi fi2) as [f2|].
  pose (Q:=SomeInj _ _ H).
  rewrite <- Q.
  simpl in * |- *.
  apply impl_eq ;   fold foI.
  * apply (IHfi1 f1 eq_refl).
  * apply (IHfi2 f2 eq_refl).
  * inversion H.
  * inversion H.
+  intros r H.
simpl in * |- *.
 destruct (isParamF xi (Fora x fi) ) eqn:tuc.
2 : {
Check NPthenNCASF.
rewrite NPthenNCASF in H.
 pose (Q:=SomeInj _ _ H).
rewrite <- Q.
apply lem2.
pose (J:=(PeanoNat.Nat.eqb x xi)).
simpl.
simpl in tuc.
destruct (PeanoNat.Nat.eqb x xi) (*as [J0|J1]*).
reflexivity.
destruct (isParamF xi fi).
inversion tuc.
reflexivity.
assumption.
}
simpl in *|-*.
destruct (PeanoNat.Nat.eqb x xi) eqn:k1.
inversion tuc.
destruct (isParamF xi fi) eqn:k2.
destruct (isParamT x t) eqn:k3.
inversion H.
destruct (substF t xi fi) eqn:k4.
simpl in *|-*.
pose(Q:=SomeInj _ _ H).
rewrite <- Q.
simpl in *|-*.
assert (U : forall m :X, (foI (cng pi x m) f) = (foI (cng (cng pi xi (teI pi t)) x m) fi)).
intro m.
admit.
rewrite U.
apply ap.

ENDENDENDENDENDENDENDENDENDENDENDENDENDENDENDENDENDENDENDENDENDEND

apply IHfi.
symmetry.
simpl.
rewrite <- IHfi.

HJJHJHJH

simpl.
destruct (PeanoNat.Nat.eqb x xi) eqn:xxi.
admit.
admit.
admit.
  simpl in *|-*.

  pose (Q:=SomeInj _ _ H).
  pose (E:=proj1 (@PeanoNat.Nat.eqb_eq x xi) xxi).
  rewrite -> E.
  rewrite <- Q.
  simpl in * |- *.
Check fun m=>(cng (cng pi xi (teI pi t)) xi m).
Check fun m1 m2 =>(functional_extensionality _ _ (dbl_cng pi xi m1 m2)).
(*rewrite -> (fun m=> (dbl_cng  pi xi (teI pi t) m)) .*)
 (*to be continued... *)
  *
(*rewrite -> IHfi.*)
(*destruct fi; simpl.*)
  admit.
  * destruct (isParamF xi fi) eqn: yu.
    destruct (isParamT x t) eqn: os.
simpl.
Abort.
(*
Vector.map (teI pi) (Vector.map (substT t xi) v) =
Vector.map (teI (cng pi xi (teI pi t))) v
*)
End Lem2.

(* lem2  is not proven yet! *)

Fixpoint correct (f:Fo) (l:list Fo) (val:SetVars->X) (m:PR l f)
(lfi : forall h:Fo, (InL h l)->(foI val h)) {struct m}: foI val f.
Proof.
destruct m (* eqn: meq *).
+ exact (lfi A i).
+ simpl.
  intros a b.
  exact a.
+ simpl.
  intros a b c.
  exact (a c (b c)).
+ destruct (substF t xi ph) eqn: j.
  2 : {simpl. trivial. }
  apply (correct _ l).
  2 : {assumption. }
  simpl.
pose (Z:=(@Ded (Fora xi ph) f l )).
simple refine (Z _ _ ).
(*
  pose (W:= lfi f).
  destruct (Nat.eqb r xi).
  simpl in H.
  exact H.
  unfold foI.
  simpl.
*)
Abort.

End cor.
(* Definition ACK : list Fo := . *)

End VS.

(*Theorem AA (a:nat):nat.
elim a;
[> revert a | idtac 1].
elim a;
[> idtac 1 | idtac 1].
destruct a.
(*Unfocus.*)
[> idtac 1 | idtac 1].*)