(** * Typechecking: A Typechecker for STLC *)

(** The [has_type] relation of the STLC defines what it means for a
    term to belong to a type (in some context).  But it doesn't, by
    itself, give us an algorithm for _checking_ whether or not a term
    is well typed.

    Fortunately, the rules defining [has_type] are _syntax directed_
    -- that is, for every syntactic form of the language, there is
    just one rule that can be used to give a type to terms of that
    form.  This makes it straightforward to translate the typing rules
    into clauses of a typechecking _function_ that takes a term and a
    context and either returns the term's type or else signals that
    the term is not typable.  *)

(** This short chapter constructs such a function and proves it
    correct. *)

Set Warnings "-notation-overridden,-parsing".
Require Import Coq.Bool.Bool.
From PLF Require Import Maps.
From PLF Require Import Smallstep.
From PLF Require Import Stlc.
From PLF Require MoreStlc.

Module STLCTypes.
Export STLC.

(* ################################################################# *)
(** * Comparing Types *)

(** First, we need a function to compare two types for equality... *)

Fixpoint beq_ty (T1 T2:ty) : bool :=
  match T1,T2 with
  | TBool, TBool =>
      true
  | TArrow T11 T12, TArrow T21 T22 =>
      andb (beq_ty T11 T21) (beq_ty T12 T22)
  | _,_ =>
      false
  end.

(** ... and we need to establish the usual two-way connection between
    the boolean result returned by [beq_ty] and the logical
    proposition that its inputs are equal. *)

Lemma beq_ty_refl : forall T1,
  beq_ty T1 T1 = true.
Proof.
  intros T1. induction T1; simpl.
    reflexivity.
    rewrite IHT1_1. rewrite IHT1_2. reflexivity.  Qed.

Lemma beq_ty__eq : forall T1 T2,
  beq_ty T1 T2 = true -> T1 = T2.
Proof with auto.
  intros T1. induction T1; intros T2 Hbeq; destruct T2; inversion Hbeq.
  - (* T1=TBool *)
    reflexivity.
  - (* T1=TArrow T1_1 T1_2 *)
    rewrite andb_true_iff in H0. inversion H0 as [Hbeq1 Hbeq2].
    apply IHT1_1 in Hbeq1. apply IHT1_2 in Hbeq2. subst...  Qed.
End STLCTypes.

(* ################################################################# *)
(** * The Typechecker *)

(** The typechecker works by walking over the structure of the given
    term, returning either [Some T] or [None].  Each time we make a
    recursive call to find out the types of the subterms, we need to
    pattern-match on the results to make sure that they are not
    [None].  Also, in the [tapp] case, we use pattern matching to
    extract the left- and right-hand sides of the function's arrow
    type (and fail if the type of the function is not [TArrow T11 T12]
    for some [T11] and [T12]). *)

Module FirstTry.
Import STLCTypes.

Fixpoint type_check (Gamma:context) (t:tm) : option ty :=
  match t with
  | tvar x =>
      Gamma x
  | tabs x T11 t12 =>
      match type_check (update Gamma x T11) t12 with
      | Some T12 => Some (TArrow T11 T12)
      | _ => None
      end
  | tapp t1 t2 =>
      match type_check Gamma t1, type_check Gamma t2 with
      | Some (TArrow T11 T12),Some T2 =>
          if beq_ty T11 T2 then Some T12 else None
      | _,_ => None
      end
  | ttrue =>
      Some TBool
  | tfalse =>
      Some TBool
  | tif guard t f =>
      match type_check Gamma guard with
      | Some TBool =>
          match type_check Gamma t, type_check Gamma f with
          | Some T1, Some T2 =>
              if beq_ty T1 T2 then Some T1 else None
          | _,_ => None
          end
      | _ => None
      end
  end.

End FirstTry.

(* ################################################################# *)
(** * Digression: Improving the Notation *)

(** Before we consider the properties of this algorithm, let's write
    it out again in a cleaner way, using "monadic" notations in the
    style of Haskell to streamline the plumbing of options.  First, we
    define a notation for composing two potentially failing (i.e.,
    option-returning) computations: *)

Notation " x <- e1 ;; e2"
   := (match e1 with
         | Some x => e2
         | None => None
       end)
   (right associativity, at level 60).

(** Second, we define [return] and [fail] as synonyms for [Some] and
    [None]: *)

Notation " 'return' e "
  := (Some e) (at level 60).

Notation " 'fail' "
  := None.

Module STLCChecker.
Import STLCTypes.

(** Now we can write the same type-checking function in a more
    "imperative" style using these notations. *)

Fixpoint type_check (Gamma:context) (t:tm) : option ty :=
  match t with
  | tvar x =>
      match Gamma x with
      | Some T => return T
      | None   => fail
      end
  | tabs x T11 t12 =>
      T12 <- type_check (update Gamma x T11) t12 ;;
      return (TArrow T11 T12)
  | tapp t1 t2 =>
      T1 <- type_check Gamma t1 ;;
      T2 <- type_check Gamma t2 ;;
      match T1 with
      | TArrow T11 T12 =>
          if beq_ty T11 T2 then return T12 else fail
      | _ => fail
      end
  | ttrue =>
      return TBool
  | tfalse =>
      return TBool
  | tif guard t1 t2 =>
      Tguard <- type_check Gamma guard ;;
      T1 <- type_check Gamma t1 ;;
      T2 <- type_check Gamma t2 ;;
      match Tguard with
      | TBool =>
          if beq_ty T1 T2 then return T1 else fail
      | _ => fail
      end
  end.

(* ################################################################# *)
(** * Properties *)

(** To verify that th typechecking algorithm is correct, we show that
    it is _sound_ and _complete_ for the original [has_type]
    relation -- that is, [type_check] and [has_type] define the same
    partial function. *)

Theorem type_checking_sound : forall Gamma t T,
  type_check Gamma t = Some T -> has_type Gamma t T.
Proof with eauto.
  intros Gamma t. generalize dependent Gamma.
  induction t; intros Gamma T Htc; inversion Htc.
  - (* tvar *) rename s into x. destruct (Gamma x) eqn:H.
    rename t into T'. inversion H0. subst. eauto. solve_by_invert.
  - (* tapp *)
    remember (type_check Gamma t1) as TO1.
    destruct TO1 as [T1|]; try solve_by_invert;
    destruct T1 as [|T11 T12]; try solve_by_invert;
    remember (type_check Gamma t2) as TO2;
    destruct TO2 as [T2|]; try solve_by_invert.
    destruct (beq_ty T11 T2) eqn: Heqb.
    apply beq_ty__eq in Heqb.
    inversion H0; subst...
    inversion H0.
  - (* tabs *)
    rename s into x. rename t into T1.
    remember (update Gamma x T1) as G'.
    remember (type_check G' t0) as TO2.
    destruct TO2; try solve_by_invert.
    inversion H0; subst...
  - (* ttrue *) eauto.
  - (* tfalse *) eauto.
  - (* tif *)
    remember (type_check Gamma t1) as TOc.
    remember (type_check Gamma t2) as TO1.
    remember (type_check Gamma t3) as TO2.
    destruct TOc as [Tc|]; try solve_by_invert.
    destruct Tc; try solve_by_invert;
    destruct TO1 as [T1|]; try solve_by_invert;
    destruct TO2 as [T2|]; try solve_by_invert.
    destruct (beq_ty T1 T2) eqn:Heqb;
    try solve_by_invert.
    apply beq_ty__eq in Heqb.
    inversion H0. subst. subst...
Qed.

Theorem type_checking_complete : forall Gamma t T,
  has_type Gamma t T -> type_check Gamma t = Some T.
Proof with auto.
  intros Gamma t T Hty.
  induction Hty; simpl.
  - (* T_Var *) destruct (Gamma x0) eqn:H0; assumption.
  - (* T_Abs *) rewrite IHHty...
  - (* T_App *)
    rewrite IHHty1. rewrite IHHty2.
    rewrite (beq_ty_refl T11)...
  - (* T_True *) eauto.
  - (* T_False *) eauto.
  - (* T_If *) rewrite IHHty1. rewrite IHHty2.
    rewrite IHHty3. rewrite (beq_ty_refl T)...
Qed.

End STLCChecker.

(* ################################################################# *)
(** * Exercises *)

(** **** Exercise: 5 stars (typechecker_extensions)  *)
(** In this exercise we'll extend the typechecker to deal with the
    extended features discussed in chapter [MoreStlc].  Your job
    is to fill in the omitted cases in the following. *)

Module TypecheckerExtensions.
(* Do not modify the following line: *)
Definition manual_grade_for_type_checking_sound : option (prod nat string) := None.
(* Do not modify the following line: *)
Definition manual_grade_for_type_checking_complete : option (prod nat string) := None.
Import MoreStlc.
Import STLCExtended.

Fixpoint beq_ty (T1 T2: ty) : bool :=
  match T1,T2 with
  | TNat, TNat =>
      true
  | TUnit, TUnit =>
      true
  | TArrow T11 T12, TArrow T21 T22 =>
      andb (beq_ty T11 T21) (beq_ty T12 T22)
  | TProd T11 T12, TProd T21 T22 =>
      andb (beq_ty T11 T21) (beq_ty T12 T22)
  | TSum T11 T12, TSum T21 T22 =>
      andb (beq_ty T11 T21) (beq_ty T12 T22)
  | TList T11, TList T21 =>
      beq_ty T11 T21
  | _,_ =>
      false
  end.

Lemma beq_ty_refl : forall T1,
  beq_ty T1 T1 = true.
Proof.
  intros T1.
  induction T1; simpl;
    try reflexivity;
    try (rewrite IHT1_1; rewrite IHT1_2; reflexivity);
    try (rewrite IHT1; reflexivity).  Qed.

Lemma beq_ty__eq : forall T1 T2,
  beq_ty T1 T2 = true -> T1 = T2.
Proof.
  intros T1.
  induction T1; intros T2 Hbeq; destruct T2; inversion Hbeq;
    try reflexivity;
    try (rewrite andb_true_iff in H0; inversion H0 as [Hbeq1 Hbeq2];
         apply IHT1_1 in Hbeq1; apply IHT1_2 in Hbeq2; subst; auto);
    try (apply IHT1 in Hbeq; subst; auto).
 Qed.

Fixpoint type_check (Gamma:context) (t:tm) : option ty :=
  match t with
  | tvar x =>
      match Gamma x with
      | Some T => return T
      | None   => fail
      end
  | tabs x T11 t12 =>
      T12 <- type_check (update Gamma x T11) t12 ;;
      return (TArrow T11 T12)
  | tapp t1 t2 =>
      T1 <- type_check Gamma t1 ;;
      T2 <- type_check Gamma t2 ;;
      match T1 with
      | TArrow T11 T12 =>
          if beq_ty T11 T2 then return T12 else fail
      | _ => fail
      end
  | tnat _ =>
      return TNat
  | tsucc t1 =>
      T1 <- type_check Gamma t1 ;;
      match T1 with
      | TNat => return TNat
      | _ => fail
      end
  | tpred t1 =>
      T1 <- type_check Gamma t1 ;;
      match T1 with
      | TNat => return TNat
      | _ => fail
      end
  | tmult t1 t2 =>
      T1 <- type_check Gamma t1 ;;
      T2 <- type_check Gamma t2 ;;
      match T1, T2 with
      | TNat, TNat => return TNat
      | _,_        => fail
      end
  | tif0 guard t f =>
      Tguard <- type_check Gamma guard ;;
      T1 <- type_check Gamma t ;;
      T2 <- type_check Gamma f ;;
      match Tguard with
      | TNat => if beq_ty T1 T2 then return T1 else fail
      | _ => fail
      end
  (* FILL IN HERE *)
  | tlcase t0 t1 x21 x22 t2 =>
      match type_check Gamma t0 with
      | Some (TList T) =>
          match type_check Gamma t1,
                type_check (update (update Gamma x22 (TList T)) x21 T) t2 with
          | Some T1', Some T2' =>
              if beq_ty T1' T2' then Some T1' else None
          | _,_ => None
          end
      | _ => None
      end
  (* FILL IN HERE *)
  | _ => None  (* ... and delete this line *)
  end.

(** Just for fun, we'll do the soundness proof with just a bit more
    automation than above, using these "mega-tactics": *)

Ltac invert_typecheck Gamma t T :=
  remember (type_check Gamma t) as TO;
  destruct TO as [T|];
  try solve_by_invert; try (inversion H0; eauto); try (subst; eauto).

Ltac analyze T T1 T2 :=
  destruct T as [T1 T2| | | T1 T2| T1 T2| T1]; try solve_by_invert.

Ltac fully_invert_typecheck Gamma t T T1 T2 :=
  let TX := fresh T in
  remember (type_check Gamma t) as TO;
  destruct TO as [TX|]; try solve_by_invert;
  destruct TX as [T1 T2| | | T1 T2| T1 T2| T1];
  try solve_by_invert; try (inversion H0; eauto); try (subst; eauto).

Ltac case_equality S T :=
  destruct (beq_ty S T) eqn: Heqb;
  inversion H0; apply beq_ty__eq in Heqb; subst; subst; eauto.

Theorem type_checking_sound : forall Gamma t T,
  type_check Gamma t = Some T -> has_type Gamma t T.
Proof with eauto.
  intros Gamma t. generalize dependent Gamma.
  induction t; intros Gamma T Htc; inversion Htc.
  - (* tvar *) rename s into x. destruct (Gamma x) eqn:H.
    rename t into T'. inversion H0. subst. eauto. solve_by_invert.
  - (* tapp *)
    invert_typecheck Gamma t1 T1.
    invert_typecheck Gamma t2 T2.
    analyze T1 T11 T12.
    case_equality T11 T2.
  - (* tabs *)
    rename s into x. rename t into T1.
    remember (update Gamma x T1) as Gamma'.
    invert_typecheck Gamma' t0 T0.
  - (* tnat *) eauto.
  - (* tsucc *)
    rename t into t1.
    fully_invert_typecheck Gamma t1 T1 T11 T12.
  - (* tpred *)
    rename t into t1.
    fully_invert_typecheck Gamma t1 T1 T11 T12.
  - (* tmult *)
    invert_typecheck Gamma t1 T1.
    invert_typecheck Gamma t2 T2.
    analyze T1 T11 T12; analyze T2 T21 T22.
    inversion H0. subst. eauto.
  - (* tif0 *)
    invert_typecheck Gamma t1 T1.
    invert_typecheck Gamma t2 T2.
    invert_typecheck Gamma t3 T3.
    destruct T1; try solve_by_invert.
    case_equality T2 T3.
  (* FILL IN HERE *)
  - (* tlcase *)
    rename s into x31. rename s0 into x32.
    fully_invert_typecheck Gamma t1 T1 T11 T12.
    invert_typecheck Gamma t2 T2.
    remember (update (update Gamma x32 (TList T11)) x31 T11) as Gamma'2.
    invert_typecheck Gamma'2 t3 T3.
    case_equality T2 T3.
  (* FILL IN HERE *)
Qed.

Theorem type_checking_complete : forall Gamma t T,
  has_type Gamma t T -> type_check Gamma t = Some T.
Proof.
  intros Gamma t T Hty.
  induction Hty; simpl;
    try (rewrite IHHty);
    try (rewrite IHHty1);
    try (rewrite IHHty2);
    try (rewrite IHHty3);
    try (rewrite (beq_ty_refl T));
    try (rewrite (beq_ty_refl T1));
    try (rewrite (beq_ty_refl T2));
    eauto.
  - destruct (Gamma x); try solve_by_invert. eauto.
  Admitted. (* ... and delete this line *)
(*
Qed. (* ... and uncomment this one *)
*)
End TypecheckerExtensions.
(** [] *)

(** **** Exercise: 5 stars, optional (stlc_step_function)  *)
(** Above, we showed how to write a typechecking function and prove it
    sound and complete for the typing relation.  Do the same for the
    operational semantics -- i.e., write a function [stepf] of type
    [tm -> option tm] and prove that it is sound and complete with
    respect to [step] from chapter [MoreStlc]. *)

Module StepFunction.
Import TypecheckerExtensions.

(* FILL IN HERE *)
End StepFunction.
(** [] *)

(** **** Exercise: 5 stars, optional (stlc_impl)  *)
(** Using the Imp parser described in the [ImpParser] chapter
    of _Logical Foundations_ as a guide, build a parser for extended
    Stlc programs.  Combine it with the typechecking and stepping
    functions from the above exercises to yield a complete typechecker
    and interpreter for this language. *)

Module StlcImpl.
Import StepFunction.

(* FILL IN HERE *)
End StlcImpl.
(** [] *)

(** $Date$ *)


(*
Sous emacs, pour avoir les symboles il faut avoir une font adequat (par exemple: "Mono")
Pour taper les symboles utf8, il faut faire:

 M-x set-input-method TeX

ensuite il suffit de taper la commande latex correspondante.

⊕  \oplus
⊗ \otimes
⊸ \multimap
⊤ \top
⊢ \vdash
*)
Require Import multiset_spec.
Require Import ILL_spec.
Require Import OrderedType.
Require Import Utf8_core.
Require Import vars.

Require Import ILL.
(** Les preuves de epsrc_case_for_support.pdf. *)
(* Module MakePaperProofs(Vars : OrderedType)(M : ILL_sig(Vars)).
  Import M.
  Import FormulaMultiSet.
  Module Import Tactics := ILL_tactics(Vars)(M).
  (** Figure 1 de epsrc_case_for_support. *)
  Section figure_1.
    Parameters vD vP vR vS : Vars.t.
    Local Notation "'D'" := (Proposition vD).
    Local Notation "'P'" := (Proposition vP).
    Local Notation "'R'":= (Proposition vR).
    Local Notation "'S'" := (Proposition vS).

    Hypothesis D_neq_P : not (Vars.eq vD vP).
    Hypothesis D_neq_R : not (Vars.eq vD vR).
    Hypothesis D_neq_S : not (Vars.eq vD vS).
    Hypothesis P_neq_R : not (Vars.eq vP vR).
    Hypothesis P_neq_S : not (Vars.eq vP vS).
    Hypothesis R_neq_S : not (Vars.eq vR vS).

    Lemma Proof_from_figure_1:  {D, P & 1, R & 1, D ⊸ (((P ⊸ S) ⊕ (R ⊸ (1 ⊕ (P ⊸ S)))) ⊗ D)} ⊢ ((S ⊗ D) ⊕ D).
    Proof with (try complete (try constructor; prove_multiset_eq)).
      impl_l ({D}) ({(P&1) , (R&1) })
        (D) ((((P ⊸ S) ⊕ (R ⊸ (1 ⊕ (P ⊸ S)))) ⊗ D))...
    (* search_one_goal ({D, (P ⊸ S) ⊕ (R ⊸ (1 ⊕ (P ⊸ S))), P & 1, R & 1} ⊢ (S ⊗ D) ⊕ D). *)
      times_l ((P ⊸ S) ⊕ (R ⊸ (1 ⊕ (P ⊸ S)))) D.
      oplus_l (P ⊸ S) (R ⊸ (1 ⊕ (P ⊸ S))).
    (* search_one_goal    ({P, P ⊸ S, D, R & 1} ⊢ (S ⊗ D) ⊕ D). *)
      and_l_1 P 1.
    (* search_one_goal ({1, P, P ⊸ S, D} ⊢ (S ⊗ D) ⊕ D). *)
      and_l_2 R 1.
    (* search_one_goal ({P, P ⊸ S, D} ⊢ (S ⊗ D) ⊕ D). *)
      one_l.
      apply Oplus_R_1.
      times_r ({P, (P ⊸ S) }) ({D})...
      impl_l  ({P}) (∅) (P) (S)...
      and_l_1 R 1.
      impl_l({R}) ({D, P & 1 }) (R) ((1 ⊕ (P ⊸ S)))...
      oplus_l 1 (P ⊸ S).
      one_l.
      and_l_2 P 1.
      one_l.
      apply Oplus_R_2...
      and_l_1 (P) 1.
      apply Oplus_R_1.
      times_r ({ P , P ⊸ S}) ({D})...
      impl_l ({P}) (∅) (P) (S)...
    Qed.

    (* Same proof as above but with some more automation *)
    Lemma Copy_Proof_from_figure_1_with_weak_search:
    {D, P & 1, R & 1, D ⊸ (((P ⊸ S) ⊕ (R ⊸ (1 ⊕ (P ⊸ S)))) ⊗ D)} ⊢ ((S ⊗ D) ⊕ D).
    Proof with (try complete (try constructor; prove_multiset_eq)).
      impl_l  ({D}) ({(P&1) , (R&1) }) (D) ((((P ⊸ S) ⊕ (R ⊸ (1 ⊕ (P ⊸ S)))) ⊗ D))...
      search_one_goal ({D, (P ⊸ S) ⊕ (R ⊸ (1 ⊕ (P ⊸ S))), P & 1, R & 1} ⊢ (S ⊗ D) ⊕ D).
      oplus_l (P ⊸ S) (R ⊸ (1 ⊕ (P ⊸ S))).
      search_one_goal ({P, P ⊸ S, D} ⊢ (S ⊗ D) ⊕ D).
      apply Oplus_R_1.
      times_r ({P, (P ⊸ S) }) ({D})...
      impl_l ({P}) (∅) (P) (S)...
      search_one_goal ({R, R ⊸ (1 ⊕ (P ⊸ S)), D, P & 1} ⊢ (S ⊗ D) ⊕ D).
      impl_l ({R}) ({D, P & 1 }) (R) ((1 ⊕ (P ⊸ S)))...
      oplus_l 1 (P ⊸ S).
      search_one_goal ({D} ⊢ (S ⊗ D) ⊕ D).
      apply Oplus_R_2...
      search_one_goal ( {P ⊸ S, D, P} ⊢ (S ⊗ D) ⊕ D).
      apply Oplus_R_1.
      times_r ({ P , P ⊸ S}) ({D})...
      impl_l ({P}) (∅) (P) (S)...
    Qed.

    Lemma Copy_Proof_from_figure_1_with_stronger_search:
    {D, P & 1, R & 1, D ⊸ (((P ⊸ S) ⊕ (R ⊸ (1 ⊕ (P ⊸ S)))) ⊗ D)} ⊢ ((S ⊗ D) ⊕ D).
    Proof with try complete (finish_proof_strong || prove_multiset_eq).
      search_one_goal_strong ({D, (P ⊸ S) ⊕ (R ⊸ (1 ⊕ (P ⊸ S))), P & 1, R & 1} ⊢ (S ⊗ D) ⊕ D).
      oplus_l (P ⊸ S) (R ⊸ (1 ⊕ (P ⊸ S))).

      search_one_goal_strong ({P, P ⊸ S, D} ⊢ (S ⊗ D)).
      times_r ({P, (P ⊸ S) }) ({D})...

      search_one_goal_strong ({1 ⊕ (P ⊸ S), D, P & 1} ⊢ (S ⊗ D) ⊕ D).
      oplus_l 1 (P ⊸ S)...
      search_one_goal_strong ( {P ⊸ S, D, P} ⊢ (S ⊗ D)).
      times_r  ({ P , P ⊸ S}) ({D})...
    Qed.
  End figure_1.

  (** Figure 5 de epsrc_case_for_support. *)
  Section figure_5.
    Parameters vD' vD0' vD1' vD2' vH' vF' vG' vM' vL' : Vars.t.
    Local Notation "'D'" := (Proposition vD').
    Local Notation "'D₁'" := (Proposition vD1').
    Local Notation "'D₀'" := (Proposition vD0').
    Local Notation "'D₂'" := (Proposition vD2').
    Local Notation "'H'" := (Proposition vH').
    Local Notation "'F'":= (Proposition vF').
    Local Notation "'G'" := (Proposition vG').
    Local Notation "'M'" := (Proposition vM').
    Local Notation "'L'" := (Proposition vL').

    Local Notation "'ρ'" := { H,F,L,D₂, G⊸(!(H⊸(H⊗M))) }.
    Local Notation "'μ'" := { !((D₁⊗M)⊸D₀),!((D₂⊗M)⊸D₁)}.
    Local Notation "'λ'" := { !((L⊗D₀)⊸(L⊗D₁)),!((L⊗D₁)⊸(L⊗D₂))}.

  Ltac bang_c  p'   :=
    match goal with
      |- ILL_proof ?env _ =>
        match env with
          | context C [(!p'::?env')] =>
            let e := context C [ env' ] in
              with_multiset (!p'::e) ltac:(apply Bang_C)
        end
    end.

  Ltac bang_d  p'   :=
    match goal with
      |- ILL_proof ?env _ =>
        match env with
          | context C [(!p'::?env')] =>
            let e := context C [ env' ] in
              with_multiset (!p'::e) ltac:(apply Bang_D)
        end
    end.

    Lemma figure_5 :
      {H,L,G,D₂,G⊸!(H⊸(H⊗M)),(L⊗(D₂⊗H))⊸(L⊗(D₀⊗((L⊗D₂)⊸D)))}∪λ∪μ⊢D.
    Proof with try complete (finish_proof_strong || prove_multiset_eq).
      search_one_goal_strong ({H,L,D₂,!(H⊸(H⊗M)),(L⊗(D₂⊗H))⊸(L⊗(D₀⊗((L⊗D₂)⊸D)))}∪λ∪μ⊢D).
      bang_c (H⊸(H⊗M)).
      bang_d ((H⊸(H⊗M))).
      search_one_goal_strong ((H ⊗ M)
        :: {L, D₂, !(H ⊸ (H ⊗ M)),
          (L ⊗ (D₂ ⊗ H)) ⊸ (L ⊗ (D₀ ⊗ ((L ⊗ D₂) ⊸ D)))} ∪
        λ ∪ μ⊢D).
      search_one_goal_strong ( {H ,M,L, D₂, !(H ⊸ (H ⊗ M)),
        (L ⊗ (D₂ ⊗ H)) ⊸ (L ⊗ (D₀ ⊗ ((L ⊗ D₂) ⊸ D)))} ∪
      λ ∪ μ⊢D).
      bang_c ((D₂⊗M)⊸D₁).
      bang_d ((D₂⊗M)⊸D₁).
      impl_l {M,D₂} ({H, L,  !(H ⊸ (H ⊗ M)), (L ⊗ (D₂ ⊗ H)) ⊸ (L ⊗ (D₀ ⊗ ((L ⊗ D₂) ⊸ D)))} ∪ λ ∪ μ) (D₂⊗M) (D₁).
      times_r ({ D₂}) ({M})...
      search_one_goal_strong ({D₁,H, L,  (L ⊗ (D₂ ⊗ H)) ⊸ (L ⊗ (D₀ ⊗ ((L ⊗ D₂) ⊸ D)))} ∪ λ ⊢ D).
      bang_c ((L⊗D₁)⊸(L⊗D₂))...
      bang_d ((L⊗D₁)⊸(L⊗D₂))...
      impl_l ({L,D₁}) ({H, (L ⊗ (D₂ ⊗ H)) ⊸ (L ⊗ (D₀ ⊗ ((L ⊗ D₂) ⊸ D)))}∪λ) (L⊗D₁) (L⊗D₂)...
      times_r  ({L}) ({D₁})...
      search_one_goal_strong ({L,D₂,H, (L ⊗ (D₂ ⊗ H)) ⊸ (L ⊗ (D₀ ⊗ ((L ⊗ D₂) ⊸ D)))} ∪ λ ⊢ D).
      impl_l ({L,D₂,H}) ({ !((L⊗D₀)⊸(L⊗D₁)),!((L⊗D₁)⊸(L⊗D₂))}) (L⊗(D₂⊗H)) ((L ⊗ (D₀ ⊗ ((L ⊗ D₂) ⊸ D))))...
      times_r ({L}) ({D₂,H})...
      times_r ({D₂}) ({H})...
      search_one_goal_strong ({L,D₀,((L ⊗ D₂) ⊸ D)}∪λ⊢D).
      bang_c ((L⊗D₀)⊸(L⊗D₁))...
      bang_d ((L⊗D₀)⊸(L⊗D₁))...
      impl_l
        ({L,D₀})
        ({!((L ⊗ D₀) ⊸ (L ⊗ D₁)), (L ⊗ D₂) ⊸ D, !((L ⊗ D₁) ⊸ (L ⊗ D₂))})
        (L⊗D₀)
        (L⊗D₁)...
      times_r ({L}) ({D₀})...
      search_one_goal_strong (   {L ⊗ D₁, (L ⊗ D₂) ⊸ D, !((L ⊗ D₁) ⊸ (L ⊗ D₂))} ⊢ D).
      bang_c
      (((L ⊗ D₁) ⊸ (L ⊗ D₂)))...
      bang_d
        (((L ⊗ D₁) ⊸ (L ⊗ D₂)))...
    Qed.

  End figure_5.
End MakePaperProofs.
*)
Require Import String.
Require Import Setoid.

Module PaperProofsString.
  Module M := ILL_Make(VarsString).
  Import M.
  Import FormulaMultiSet.
  Include ILL_tactics_refl(VarsString)(M).

  (** Figure 1 de epsrc_case_for_support. *)
  Section figure_1.

  Local Notation "'D'" := (Proposition "D"%string).
  Local Notation "'P'" := (Proposition "P"%string).
  Local Notation "'R'":= (Proposition "R"%string).
  Local Notation "'S'" := (Proposition "S"%string).

  Lemma Copy_Proof_from_figure_1:
  {D, P & 1, R & 1, D ⊸ (((P ⊸ S) ⊕ (R ⊸ (1 ⊕ (P ⊸ S)))) ⊗ D)} ⊢ ((S ⊗ D) ⊕ D).
  Proof with (try now (try constructor; prove_multiset_eq)).
      impl_l ({D}) ({(P&1) , (R&1) })
        (D) ((((P ⊸ S) ⊕ (R ⊸ (1 ⊕ (P ⊸ S)))) ⊗ D))...
    (* search_one_goal ({D, (P ⊸ S) ⊕ (R ⊸ (1 ⊕ (P ⊸ S))), P & 1, R & 1} ⊢ (S ⊗ D) ⊕ D). *)
      times_l ((P ⊸ S) ⊕ (R ⊸ (1 ⊕ (P ⊸ S)))) D.
      oplus_l (P ⊸ S) (R ⊸ (1 ⊕ (P ⊸ S))).
    (* search_one_goal    ({P, P ⊸ S, D, R & 1} ⊢ (S ⊗ D) ⊕ D). *)
      and_l_1 P 1.
    (* search_one_goal ({1, P, P ⊸ S, D} ⊢ (S ⊗ D) ⊕ D). *)
      and_l_2 R 1.
    (* search_one_goal ({P, P ⊸ S, D} ⊢ (S ⊗ D) ⊕ D). *)
      one_l.
      apply Oplus_R_1.
      times_r ({P, (P ⊸ S) }) ({D})...
      impl_l  ({P}) (∅) (P) (S)...
      and_l_1 R 1.
      impl_l({R}) ({D, P & 1 }) (R) ((1 ⊕ (P ⊸ S)))...
      oplus_l 1 (P ⊸ S).
      one_l.
      and_l_2 P 1.
      one_l.
      apply Oplus_R_2...
      and_l_1 (P) 1.
      apply Oplus_R_1.
      times_r ({ P , P ⊸ S}) ({D})...
      impl_l ({P}) (∅) (P) (S)...
    Qed.

  (* Same proof as above but with some more automation *)
  Lemma Copy_Proof_from_figure_1_with_weak_search:
  {D, P & 1, R & 1, D ⊸ (((P ⊸ S) ⊕ (R ⊸ (1 ⊕ (P ⊸ S)))) ⊗ D)} ⊢ ((S ⊗ D) ⊕ D).
  Proof with (try now (try constructor; prove_multiset_eq)).
    impl_l  ({D}) ({(P&1) , (R&1) }) (D) ((((P ⊸ S) ⊕ (R ⊸ (1 ⊕ (P ⊸ S)))) ⊗ D))...
    search_one_goal ({D, (P ⊸ S) ⊕ (R ⊸ (1 ⊕ (P ⊸ S))), P & 1, R & 1} ⊢ (S ⊗ D) ⊕ D).
    oplus_l (P ⊸ S) (R ⊸ (1 ⊕ (P ⊸ S))).
    search_one_goal ({P, P ⊸ S, D} ⊢ (S ⊗ D) ⊕ D).
    apply Oplus_R_1.
    times_r ({P, (P ⊸ S) }) ({D})...
    impl_l ({P}) (∅) (P) (S)...
    search_one_goal ({R, R ⊸ (1 ⊕ (P ⊸ S)), D, P & 1} ⊢ (S ⊗ D) ⊕ D).
    impl_l ({R}) ({D, P & 1 }) (R) ((1 ⊕ (P ⊸ S)))...
    oplus_l 1 (P ⊸ S).
    search_one_goal ({D} ⊢ (S ⊗ D) ⊕ D).
    apply Oplus_R_2...
    search_one_goal ( {P ⊸ S, D, P} ⊢ (S ⊗ D) ⊕ D).
    apply Oplus_R_1.
    times_r ({ P , P ⊸ S}) ({D})...
    impl_l ({P}) (∅) (P) (S)...
  Qed.

  Lemma Copy_Proof_from_figure_1_with_stronger_search:
    {D, P & 1, R & 1, D ⊸ (((P ⊸ S) ⊕ (R ⊸ (1 ⊕ (P ⊸ S)))) ⊗ D)} ⊢ ((S ⊗ D) ⊕ D).
  Proof with try now (finish_proof_strong || prove_multiset_eq).
    search_one_goal_strong ({D, (P ⊸ S) ⊕ (R ⊸ (1 ⊕ (P ⊸ S))), P & 1, R & 1} ⊢ (S ⊗ D) ⊕ D).
    oplus_l (P ⊸ S) (R ⊸ (1 ⊕ (P ⊸ S))).

    search_one_goal_strong ({P, P ⊸ S, D} ⊢ (S ⊗ D)).
    times_r ({P, (P ⊸ S) }) ({D})...

    search_one_goal_strong ({1 ⊕ (P ⊸ S), D, P & 1} ⊢ (S ⊗ D) ⊕ D).
    oplus_l 1 (P ⊸ S)...
    search_one_goal_strong ( {P ⊸ S, D, P} ⊢ (S ⊗ D)).
    times_r  ({ P , P ⊸ S}) ({D})...
  Qed.
End figure_1.

(** Figure 5 de epsrc_case_for_support. *)
Section figure_5.
  Local Notation "'D'" := (Proposition "vD'"%string).
  Local Notation "'D₁'" := (Proposition "vD1'"%string).
  Local Notation "'D₀'" := (Proposition "vD0'"%string).
  Local Notation "'D₂'" := (Proposition "vD2'"%string).
  Local Notation "'H'" := (Proposition "vH'"%string).
  Local Notation "'F'":= (Proposition "vF'"%string).
  Local Notation "'G'" := (Proposition "vG'"%string).
  Local Notation "'M'" := (Proposition "vM'"%string).
  Local Notation "'L'" := (Proposition "vL'"%string).

  Local Notation "'ρ'" := ({ H,F,L,D₂, G⊸(!(H⊸(H⊗M))) }).
  Local Notation "'μ'" := ({ !((D₁⊗M)⊸D₀),!((D₂⊗M)⊸D₁)}).
  Local Notation "'λ'" := ({ !((L⊗D₀)⊸(L⊗D₁)),!((L⊗D₁)⊸(L⊗D₂))}).

  (* Ltac bang_c  p'   :=  *)
  (*   match goal with  *)
  (*     |- ILL_proof ?env _ => *)
  (*       match env with *)
  (*         | context C [(!p'::?env')] => *)
  (*           let e := context C [ env' ] in   *)
  (*             with_multiset (!p'::e) ltac:(apply Bang_C) *)
  (*       end *)
  (*   end. *)

  (* Ltac bang_d  p'   :=  *)
  (*   match goal with  *)
  (*     |- ILL_proof ?env _ => *)
  (*       match env with *)
  (*         | context C [(!p'::?env')] => *)
  (*           let e := context C [ env' ] in   *)
  (*             with_multiset (!p'::e) ltac:(apply Bang_D) *)
  (*       end *)
  (*   end. *)

  Lemma figure_5 :
    {H,L,G,D₂,G⊸!(H⊸(H⊗M)),(L⊗(D₂⊗H))⊸(L⊗(D₀⊗((L⊗D₂)⊸D)))}∪λ∪μ⊢D.
  Proof with try now (finish_proof_strong || prove_multiset_eq).
      search_one_goal_strong ({H,L,D₂,!(H⊸(H⊗M)),(L⊗(D₂⊗H))⊸(L⊗(D₀⊗((L⊗D₂)⊸D)))}∪λ∪μ⊢D).
      bang_c (H⊸(H⊗M)).
      bang_d ((H⊸(H⊗M))).
      search_one_goal_strong ((H ⊗ M)
        :: {L, D₂, !(H ⊸ (H ⊗ M)),
          (L ⊗ (D₂ ⊗ H)) ⊸ (L ⊗ (D₀ ⊗ ((L ⊗ D₂) ⊸ D)))} ∪
        λ ∪ μ⊢D).
      search_one_goal_strong ( {H ,M,L, D₂, !(H ⊸ (H ⊗ M)),
        (L ⊗ (D₂ ⊗ H)) ⊸ (L ⊗ (D₀ ⊗ ((L ⊗ D₂) ⊸ D)))} ∪
      λ ∪ μ⊢D).
      bang_c ((D₂⊗M)⊸D₁).
      bang_d ((D₂⊗M)⊸D₁).
      impl_l ({M,D₂}) ({H, L,  !(H ⊸ (H ⊗ M)), (L ⊗ (D₂ ⊗ H)) ⊸ (L ⊗ (D₀ ⊗ ((L ⊗ D₂) ⊸ D)))} ∪ λ ∪ μ) (D₂⊗M) (D₁).
      times_r ({ D₂}) ({M})...
      search_one_goal_strong ({D₁,H, L,  (L ⊗ (D₂ ⊗ H)) ⊸ (L ⊗ (D₀ ⊗ ((L ⊗ D₂) ⊸ D)))} ∪ λ ⊢ D).
      bang_c ((L⊗D₁)⊸(L⊗D₂))...
      bang_d ((L⊗D₁)⊸(L⊗D₂))...
      impl_l ({L,D₁}) ({H, (L ⊗ (D₂ ⊗ H)) ⊸ (L ⊗ (D₀ ⊗ ((L ⊗ D₂) ⊸ D)))}∪λ) (L⊗D₁) (L⊗D₂)...
      times_r  ({L}) ({D₁})...
      search_one_goal_strong ({L,D₂,H, (L ⊗ (D₂ ⊗ H)) ⊸ (L ⊗ (D₀ ⊗ ((L ⊗ D₂) ⊸ D)))} ∪ λ ⊢ D).
      impl_l ({L,D₂,H}) ({ !((L⊗D₀)⊸(L⊗D₁)),!((L⊗D₁)⊸(L⊗D₂))}) (L⊗(D₂⊗H)) ((L ⊗ (D₀ ⊗ ((L ⊗ D₂) ⊸ D))))...
      times_r ({L}) ({D₂,H})...
      times_r ({D₂}) ({H})...
      search_one_goal_strong ({L,D₀,((L ⊗ D₂) ⊸ D)}∪λ⊢D).
      bang_c ((L⊗D₀)⊸(L⊗D₁))...
      bang_d ((L⊗D₀)⊸(L⊗D₁))...
      impl_l
        ({L,D₀})
        ({!((L ⊗ D₀) ⊸ (L ⊗ D₁)), (L ⊗ D₂) ⊸ D, !((L ⊗ D₁) ⊸ (L ⊗ D₂))})
        (L⊗D₀)
        (L⊗D₁)...
      times_r ({L}) ({D₀})...
      search_one_goal_strong (   {L ⊗ D₁, (L ⊗ D₂) ⊸ D, !((L ⊗ D₁) ⊸ (L ⊗ D₂))} ⊢ D).
      bang_c
      (((L ⊗ D₁) ⊸ (L ⊗ D₂)))...
      bang_d
        (((L ⊗ D₁) ⊸ (L ⊗ D₂)))...
Qed.

End figure_5.
End PaperProofsString.


(***************************************************************************
* The pure lambda-calculus in locally nameless style - Formalization       *
* Arthur Charguéraud, January 2009                                         *
***************************************************************************)

(** This file is the appendix to the paper:
       The Locally Nameless Representation
       Arthur Charguéraud
       Journal of Automated Reasoning (JAR), May 2011 *)

Set Implicit Arguments.
Require Import LibLN LibNat.

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

Implicit Types x y z : var.

(* ********************************************************************** *)
(** Grammar of terms *)

Inductive trm : Set :=
  | trm_bvar : nat -> trm
  | trm_fvar : var -> trm
  | trm_app  : trm -> trm -> trm
  | trm_abs  : trm -> trm.

(* ********************************************************************** *)
(** Opening *)

Fixpoint open_rec (k : nat) (u : trm) (t : trm) {struct t} : trm :=
  match t with
  | trm_bvar i    => If k = i then u else t
  | trm_fvar x    => t
  | trm_app t1 t2 => trm_app (open_rec k u t1) (open_rec k u t2)
  | trm_abs t1    => trm_abs (open_rec (S k) u t1)
  end.

Definition open t u := open_rec 0 u t.

(* ********************************************************************** *)
(** Variable opening, defined in terms of opening *)

Definition open_var t x := open t (trm_fvar x).

Definition open_var_rec k x t := open_rec k (trm_fvar x) t.

(* ********************************************************************** *)
(** Variable closing *)

Fixpoint close_var_rec (k : nat) (z : var) (t : trm) {struct t} : trm :=
  match t with
  | trm_bvar i    => trm_bvar i
  | trm_fvar x    => If x = z then (trm_bvar k) else t
  | trm_app t1 t2 => trm_app (close_var_rec k z t1) (close_var_rec k z t2)
  | trm_abs t1    => trm_abs (close_var_rec (S k) z t1)
  end.

Definition close_var x t := close_var_rec 0 x t.

(* ********************************************************************** *)
(** Local closure, inductively defined *)

Inductive lc : trm -> Prop :=
  | lc_var : forall x,
      lc (trm_fvar x)
  | lc_app : forall t1 t2,
      lc t1 -> lc t2 -> lc (trm_app t1 t2)
  | lc_abs : forall L t1,
      (forall x, x \notin L -> lc (open_var t1 x)) ->
      lc (trm_abs t1).

Definition body t :=
  exists L, forall x, x \notin L -> lc (open_var t x).

(* ********************************************************************** *)
(** Computation of the set of free variables *)

Fixpoint fv (t : trm) {struct t} : vars :=
  match t with
  | trm_bvar i    => \{}
  | trm_fvar x    => \{x}
  | trm_app t1 t2 => (fv t1) \u (fv t2)
  | trm_abs t1    => (fv t1)
  end.

(* ********************************************************************** *)
(** Closed terms *)

Definition closed t :=
  fv t = \{}.

(* ********************************************************************** *)
(** Substitution *)

Fixpoint subst (z : var) (u : trm) (t : trm) {struct t} : trm :=
  match t with
  | trm_bvar i    => t
  | trm_fvar x    => If x = z then u else t
  | trm_app t1 t2 => trm_app (subst z u t1) (subst z u t2)
  | trm_abs t1    => trm_abs (subst z u t1)
  end.

(* ********************************************************************** *)
(** Size of a term *)

Fixpoint size (t : trm) {struct t} : nat :=
  match t with
  | trm_bvar i    => 1
  | trm_fvar x    => 1
  | trm_abs t1    => 1 + (size t1)
  | trm_app t1 t2 => 1 + (size t1) + (size t2)
  end.

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

Hint Constructors lc.

(** Tactics for freshness *)

Ltac gather_vars :=
  let A := gather_vars_with (fun x : vars => x) in
  let B := gather_vars_with (fun x : var => \{ x }) in
  let C := gather_vars_with (fun x : trm => fv x) in
  constr:(A \u B \u C).

Tactic Notation "pick_fresh" ident(x) :=
  let L := gather_vars in pick_fresh_gen L x.
Tactic Notation "pick_fresh" ident(x) "from" constr(E) :=
  let L := gather_vars in pick_fresh_gen (L \u E) x.

Tactic Notation "apply_fresh" constr(T) "as" ident(x) :=
  apply_fresh_base T gather_vars x.
Tactic Notation "apply_fresh" "*" constr(T) "as" ident(x) :=
  apply_fresh T as x; auto_star.
Tactic Notation "apply_fresh" constr(T) :=
  apply_fresh_base T gather_vars ltac_no_arg.
Tactic Notation "apply_fresh" "*" constr(T) :=
  apply_fresh T; auto_star.

Tactic Notation "exists_fresh" :=
  let y := fresh "y" in let Fry := fresh "Fr" y in
  exists_fresh_gen gather_vars y Fry.

(** Tactics for comparison of indices *)

Hint Extern 1 (_ < _) => nat_math.
Hint Extern 1 (_ <= _) => nat_math.

(** Tactics for equalities between sets *)

Lemma subset_union_2p : forall E1 E2 F1 F2 G : vars,
  E1 \c (F1 \u G) -> E2 \c (F2 \u G) -> (E1 \u E2) \c ((F1 \u F2) \u G).
Proof.
  introv H1 H2. intros x. specializes H1 x. specializes H2 x.
  repeat rewrite in_union in *. auto*.
Qed.

Lemma subset_remove_11 : forall x y : var,
  x <> y -> \{x} \c (\{x} \- \{y}).
Proof.
  introv H. intros z M. rewrite in_singleton in M. subst.
  rewrite in_remove. split. rewrite~ in_singleton. auto.
Qed.

Lemma subset_remove_2p : forall E1 E2 F1 F2 G : vars,
  E1 \c (F1 \- G) -> E2 \c (F2 \- G) -> (E1 \u E2) \c ((F1 \u F2) \- G).
Proof. introv H1 H2. forwards: subset_union_2 H1 H2. rewrite~ union_remove. Qed.

Hint Resolve subset_union_weak_l subset_union_weak_r subset_refl
  subset_union_2 subset_union_2p subset_empty_l
  subset_remove_2p subset_remove_11 : fset.

Ltac fset := first [ auto with fset ].

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

(* ********************************************************************** *)
(** Variable closing and variable opening are reciprocal of one another *)

(** Showing that [close_var] after [open_var] is the identity is easy *)

Lemma close_open_var : forall x t,
  x \notin fv t ->
  close_var x (open_var t x) = t.
Proof.
  introv. unfold open_var, open, close_var. generalize 0.
  induction t; simpl; introv Fr; fequals~.
  case_nat~. simpl. case_var~.
  case_var~.
Qed.

(** The other direction is much harder; First, we first need
    to establish the injectivity of [open_var] *)

Lemma open_var_inj : forall x t1 t2,
  x \notin (fv t1) -> x \notin (fv t2) ->
  (open_var t1 x = open_var t2 x) -> (t1 = t2).
Proof.
  introv Fr1 Fr2 Eq.
  rewrite~ <- (@close_open_var x t1).
  rewrite~ <- (@close_open_var x t2).
  fequals~.
Qed.

(** Another proof of the same injectivity result *)

Lemma open_var_inj_alternative : forall x t1 t2,
  x \notin (fv t1) -> x \notin (fv t2) ->
  (open_var t1 x = open_var t2 x) -> (t1 = t2).
Proof.
  intros x t1. unfold open_var, open. generalize 0.
  induction t1; intro k; destruct t2; simpl; intros; inversion H1;
  try solve [ fequals*
            | do 2 try case_nat; inversions~ H1; try notin_false ].
Qed.

(** We also need one (tricky) auxiliary lemma to handle the binder case *)

Lemma open_close_var_on_open_var : forall x y z t i j,
  i <> j -> y <> x -> y \notin (fv t) ->
    open_var_rec i y (open_var_rec j z (close_var_rec j x t))
  = open_var_rec j z (close_var_rec j x (open_var_rec i y t)).
Proof.
  unfold open_var_rec.
  induction t; simpl; intros; try solve [ fequals~ ].
  do 2 (case_nat; simpl); try solve [ case_var~ | case_nat~ ].
  case_var~. simpl. case_nat~.
Qed.

(** Now we can prove that [open_var] after [close_var] is the identity *)

Lemma open_close_var : forall x t,
  lc t ->
  open_var (close_var x t) x = t.
Proof.
  introv T. unfold open_var, open, close_var. generalize 0.
  induction T; simpl; introv; fequals~.
  case_var~. simpl. case_nat~.
  match goal with |- ?t = _ => pick_fresh y from (fv t) end.
   apply~ (@open_var_inj y).
   lets M: open_close_var_on_open_var. unfold open_var_rec in M.
   unfold open_var, open. rewrite~ M. apply~ H0.
Qed.

(** As a bonus, we get the injectivity of [close_var] *)

Lemma close_var_inj : forall x t1 t2,
  lc t1 -> lc t2 ->
  (close_var x t1 = close_var x t2) -> (t1 = t2).
Proof.
  introv T1 T2 Eq.
  rewrite~ <- (@open_close_var x t1).
  rewrite~ <- (@open_close_var x t2).
  fequals~.
Qed.

(* ********************************************************************** *)
(** Properties of [body] *)

(** An abstraction is locally closed iff it satifies the predicate [body] *)

Lemma lc_abs_iff_body : forall t1,
  lc (trm_abs t1) <-> body t1.
Proof. intros. unfold body. iff H; inversions* H. Qed.

(* ********************************************************************** *)
(** Interaction of [fv] with [open_var] and [close_var] *)

(** Opening with [u] adds [fv u] to the set of free variables *)

Lemma fv_open : forall t u,
  fv (open t u) \c fv t \u fv u.
Proof.
  introv. unfold open. generalize 0.
  induction t; intros k; simpl; try fset.
  case_nat; simpl; fset.
Qed.

(** In particular, opening with variable [x] adds [x] to the set
    of free variables *)

Lemma open_var_fv : forall x t,
  fv (open_var t x) \c (fv t \u \{x}).
Proof. intros. apply fv_open. Qed.

(** Closing w.r.t variable [x] removes [x] from the set of free variables *)

Lemma close_var_fv : forall x t,
  fv (close_var x t) \c (fv t \- \{x}).
Proof.
  introv. unfold close_var. generalize 0.
  induction t; intros k; simpl; try fset.
  case_var; simpl; fset.
Qed.

(* ********************************************************************** *)
(** Properties of substitution *)

(** Distributivity of [subst] on [open].
    Two (tricky) intermediate lemmas are required *)

Lemma open_rec_lc_ind : forall t j v i u, i <> j ->
  open_rec i u (open_rec j v t) = open_rec j v t ->
  open_rec i u t = t.
Proof.
  induction t; introv Nq Eq;
   simpls; inversions~ Eq; fequals*.
  case_nat~. case_nat~.
Qed.

Lemma open_rec_lc : forall u t k,
  lc t -> open_rec k u t = t.
Proof.
  unfold open_var_rec. introv T. gen k.
  induction T; intros; simpl; fequals~.
  pick_fresh y. apply~ (@open_rec_lc_ind t1 0 (trm_fvar y)).
  apply~ H0.
Qed.

Lemma subst_open : forall x u t v, lc u ->
  subst x u (open t v) = open (subst x u t) (subst x u v).
Proof.
  intros. unfold open. generalize 0.
  induction t; intros; simpl; fequals~.
  case_nat~.
  case_var~. rewrite~ open_rec_lc.
Qed.

(** In particular, we can distribute [subst] on [open_var] *)

Lemma subst_open_var : forall x y u t,
  y <> x -> lc u ->
  subst x u (open_var t y) = open_var (subst x u t) y.
Proof.
  introv N U. unfold open_var. rewrite~ subst_open.
  fequals. simpl. case_if~.
Qed.

(** For the distributivity of [subst] on [close_var],
    one simple intermediate lemmas is required to
    say that closing on a fresh name is the identity *)

Lemma close_var_rec_fresh : forall k x t,
  x \notin fv t -> close_var_rec k x t = t.
Proof.
  introv. gen k. induction t; simpl; intros; fequals*.
  case_var~.
Qed.

(** Distributivity of [subst] on [close_var] *)

Lemma subst_close_var : forall x y u t,
  y <> x -> y \notin fv u ->
  subst x u (close_var y t) = close_var y (subst x u t).
Proof.
  introv N F. unfold close_var. generalize 0.
  induction t; intros k; simpl; fequals~.
  case_var~; simpl.
    case_var~; simpl. case_var~.
    case_var~; simpl.
      rewrite~ close_var_rec_fresh.
      case_var~.
Qed.

(** Substitution for a fresh name is the identity *)

Lemma subst_fresh : forall x t u,
  x \notin fv t -> subst x u t = t.
Proof. intros. induction t; simpls; fequals~. case_var~. Qed.

(** Substitution can be introduced to decompose an opening *)

Lemma subst_intro : forall x t u,
  x \notin (fv t) -> lc u ->
  open t u = subst x u (open_var t x).
Proof.
  introv F U. unfold open_var. rewrite~ subst_open.
  fequals. rewrite~ subst_fresh. simpl. case_var~.
Qed.

(** An alternative, longer proof, but with fewer hypotheses *)

Lemma subst_intro_alternative : forall x t u,
  x \notin (fv t) ->
  open t u = subst x u (open_var t x).
Proof.
  introv H. unfold open_var, open. generalize 0. gen H.
  induction t; simpl; intros; fequals*.
  case_nat*.
  simpl. case_var*.
  case_var*.
Qed.

(** Substitution can be introduced to decompose a variable
    closing in terms of another one using a different name *)

Lemma close_var_rename : forall x y t,
  x \notin fv t ->
  close_var y t = close_var x (subst y (trm_fvar x) t).
Proof.
  introv. unfold close_var. generalize 0.
  induction t; simpl; intros k F; fequals~.
  case_var; simpl; case_var~.
Qed.

(* ********************************************************************** *)
(** Preservation of local closure through substitution and opening *)

(** Substitution of a locally closed terms into another one produces
    a locally closed term *)

Lemma subst_lc : forall z u t,
  lc u -> lc t -> lc (subst z u t).
Proof.
  introv U T. induction T; simple~.
  case_var~.
  apply_fresh lc_abs. rewrite~ <- subst_open_var.
Qed.

(** Substitution of a locally closed terms into a body one produces
    another body *)

Lemma subst_body : forall z t u,
  lc u -> body t -> body (subst z u t).
Proof.
  introv U [L H]. exists_fresh.
  rewrite~ <- subst_open_var. apply~ subst_lc.
Qed.

(** Opening of a body with a locally closed terms produces a
    locally closed term *)

Lemma open_lc : forall t u,
  body t -> lc u -> lc (open t u).
Proof.
  introv [L H] U. pick_fresh y. rewrite~ (@subst_intro y).
  apply~ subst_lc.
Qed.

(* ********************************************************************** *)
(** Two additional lemmas (not used in practical developments) *)

(** A body becomes a locally closed term when [open_var] is applied *)

Lemma open_var_lc : forall t1 x,
  body t1 -> lc (open_var t1 x).
Proof.
  introv [L M]. pick_fresh y. unfold open_var.
  rewrite~ (@subst_intro y). applys~ subst_lc.
Qed.

(** A locally closed term becomes a body when [closed_var] is applied *)

Lemma close_var_lc : forall t x,
  lc t -> body (close_var x t).
Proof.
  introv T. exists_fresh.
  rewrite~ (@close_var_rename y).
  rewrite~ open_close_var; apply~ subst_lc.
Qed.

(* ====================================================================== *)
(** ** An induction principle for locally closed terms *)

(** Interaction of [size] with [open_var] *)

Lemma size_open_var : forall x t,
  size (open_var t x) = size t.
Proof.
  intros. unfold open_var, open. generalize 0.
  induction t; intros; simple~. case_nat~.
Qed.

(** Interaction of [size] with [close_var] *)

Lemma size_close_var : forall x t,
  size (close_var x t) = size t.
Proof.
  intros. unfold close_var. generalize 0.
  induction t; intros; simple~. case_var~.
Qed.

(** The induction principle *)

Lemma lc_induct_size : forall P : trm -> Prop,
  (forall x, P (trm_fvar x)) ->
  (forall t1 t2,
     lc t1 -> P t1 -> lc t2 -> P t2 -> P (trm_app t1 t2)) ->
  (forall t1,
     body t1 ->
     (forall t2 x, x \notin fv t2 -> size t2 = size t1 ->
       lc (open_var t2 x) -> P (open_var t2 x)) ->
     P (trm_abs t1)) ->
  (forall t, lc t -> P t).
Proof.
  intros P Hvar Happ Habs t.
  induction t using (@measure_induction _ size).
  introv T. inverts T; simpl in H; auto.
  apply~ Habs. exists_fresh; auto. introv Fr Eq T.
   apply~ H. rewrite~ size_open_var.
Qed.

(* ====================================================================== *)
(** ** Alternative definition for local closure *)

(* ********************************************************************** *)
(** Local closure, recursively defined *)

Fixpoint lc_at (k:nat) (t:trm) {struct t} : Prop :=
  match t with
  | trm_bvar i    => i < k
  | trm_fvar x    => True
  | trm_app t1 t2 => lc_at k t1 /\ lc_at k t2
  | trm_abs t1    => lc_at (S k) t1
  end.

Definition lc' t := lc_at 0 t.

Definition body' t := lc_at 1 t.

(* ********************************************************************** *)
(** Equivalence of [lc] and [lc'] *)

Lemma lc_rec_open_var_rec : forall x t k,
  lc_at k (open_var_rec k x t) -> lc_at (S k) t.
Proof.
  unfold open_var_rec.
  induction t; simpl; introv H; auto*.
  case_nat; simpls~.
Qed.

Lemma lc_to_lc' : forall t,
  lc t -> lc' t.
Proof.
  introv T. induction T; unfold lc'; simple~.
  pick_fresh x. apply~ (@lc_rec_open_var_rec x). apply~ H0.
Qed.

Lemma lc_at_open_var_rec : forall x t k,
  lc_at (S k) t -> lc_at k (open_var_rec k x t).
Proof.
  unfold open_var_rec.
  induction t; simpl; introv H; auto*. case_nat; simple~.
Qed.

Lemma lc'_to_lc : forall t,
  lc' t -> lc t.
Proof.
  introv. unfold lc'.
  induction t using (@measure_induction _ size).
  destruct t; simpl; introv T'; simpl in H; auto*.
  apply_fresh lc_abs. apply H. rewrite~ size_open_var.
   apply~ lc_at_open_var_rec.
Qed.

Lemma lc_eq_lc' : lc = lc'.
Proof. extens. split. applys lc_to_lc'. applys lc'_to_lc. Qed.

(* ********************************************************************** *)
(** Equivalence of [body] and [body'] *)

Lemma body_to_body' : forall t,
  body t -> body' t.
Proof.
  introv [L H]. pick_fresh x.
  applys (@lc_rec_open_var_rec x).
  apply lc_to_lc'. apply~ H.
Qed.

Lemma body'_to_body : forall t,
  body' t -> body t.
Proof.
  introv B. exists (\{}:vars). introv F.
  apply lc'_to_lc. apply~ lc_at_open_var_rec.
Qed.

Lemma body_eq_body' : body = body'.
Proof. extens. split. applys body_to_body'. applys body'_to_body. Qed.

(* ********************************************************************** *)
(** Weakening property of [lc_at] *)

Lemma lc_at_weaken_ind : forall k1 k2 t,
  lc_at k1 t -> k1 <= k2 -> lc_at k2 t.
Proof. introv. gen k1 k2. induction t; simpl; introv T Lt; auto*. Qed.

Lemma lc_at_weaken : forall k t,
  lc' t -> lc_at k t.
Proof. introv H. apply~ (@lc_at_weaken_ind 0). Qed.

(* ********************************************************************** *)
(** Proofs revisited with [lc_at] *)

(** The inductions are now simpler because they are structural *)

Lemma lc'_abs_to_body' : forall t1,
  lc' (trm_abs t1) -> body' t1.
Proof. auto. Qed.

Lemma body'_to_lc'_abs : forall t1,
  body' t1 -> lc' (trm_abs t1).
Proof. auto. Qed.

Lemma open_var_lc' : forall x t,
  body' t -> lc' (open_var t x).
Proof.
  introv B. applys~ lc_at_open_var_rec.
Qed.

Lemma close_var_body' : forall x t,
  lc' t -> body' (close_var x t).
Proof.
  introv. unfold lc', body', close_var.
  generalize 0. induction t; simpl; intros k T; auto*.
  case_var~. simpl. nat_math.
Qed.

Lemma subst_lc' : forall z u t,
  lc' u -> lc' t -> lc' (subst z u t).
Proof.
  introv U. unfold lc'. generalize 0.
  induction t; simpl; introv T; auto*.
  case_var~. apply~ lc_at_weaken.
Qed.

Lemma subst_body' : forall z u t,
  lc' u -> body' t -> body' (subst z u t).
Proof.
  introv U. unfold body'. generalize 1.
  induction t; simpl; introv T; auto*.
  case_var~. apply~ lc_at_weaken.
Qed.

Lemma open_rec_lc'_ind : forall u t k,
  lc_at k t -> open_rec k u t = t.
Proof.
  introv. gen k. induction t; simpl; introv F; fequals*.
  case_nat~. false. nat_math.
Qed.

Lemma open_rec_lc' : forall u t k,
  lc' t -> open_rec k u t = t.
Proof.
  unfold lc'. introv T.
  apply open_rec_lc'_ind. apply* lc_at_weaken.
Qed.

Lemma subst_open' : forall x u t v, lc' u ->
  subst x u (open t v) = open (subst x u t) (subst x u v).
Proof.
  intros. unfold open. generalize 0.
  induction t; intros; simpl; fequals~.
  case_nat~.
  case_var~. rewrite~ open_rec_lc'.
Qed.

Lemma subst_intro' : forall x t u,
  x \notin (fv t) -> lc' u ->
  open t u = subst x u (open_var t x).
Proof.
  introv F U. unfold open_var. rewrite~ subst_open'.
  fequals. rewrite~ subst_fresh. simpl. case_var~.
Qed.

Lemma open_lc' : forall t u,
  body' t -> lc' u -> lc' (open t u).
Proof.
  introv B U. pick_fresh y. rewrite~ (@subst_intro' y).
  apply~ subst_lc'. apply~ open_var_lc'.
Qed.

Lemma open_close_var' : forall x t,
  lc' t ->
  open_var (close_var x t) x = t.
Proof.
  introv. unfold lc', open_var, open, close_var. generalize 0.
  induction t; simpl; introv Lt; fequals*.
  case_nat~. false. nat_math.
  case_var~. simpl. case_nat~.
Qed.

Lemma close_var_inj' : forall x t1 t2,
  lc' t1 -> lc' t2 ->
  (close_var x t1 = close_var x t2) -> (t1 = t2).
Proof.
  introv T1 T2 Eq.
  rewrite~ <- (@open_close_var' x t1).
  rewrite~ <- (@open_close_var' x t2).
  fequals~.
Qed.


(*

  Copyright 2016 University of Luxembourg

  This file is part of our formalization of Platzer's
    "A Complete Uniform Substitution Calculus for Differential Dynamic Logic"
  available here: http://arxiv.org/pdf/1601.06183.pdf (July 27, 2016).
  We refer to this formalization as DdlCoq here.

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

  DdlCoq 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 DdlCoq.  If not, see <http://www.gnu.org/licenses/>.

  authors:
    Vincent Rahli
    Marcus Völp
    Ivana Vukotic

 *)

Require Export symbol_lemmas.

(**

  This file defines FCsets and EAssignables, as well
  as some lemmas about conversion of KAssignables to EAssignables,
  and vice versa.  Beside that, lemmas for intersection, union and
  ubstraction (difference) which work with EAssignables are implemented.

*)

(* ========= About Finite/CoFinite Sets ========= *)

Inductive FCset {T} :=
| FCS_finite   (l : list T)
| FCS_infinite (l : list T).

Definition in_fcset {T} (dec : Deq T) (a : T) (e : FCset) : bool :=
  match e with
  | FCS_finite l => if in_dec dec a l then true else false
  | FCS_infinite l => if in_dec dec a l then false else true
  end.

Fixpoint disj_dec {T} (dec : Deq T) (l1 l2 : list T) : bool :=
  match l1 with
  | [] => true
  | a :: l =>
    if in_dec dec a l2 then false
    else disj_dec dec l l2
  end.

Fixpoint included_dec {T} (dec : Deq T) (l1 l2 : list T) : bool :=
  match l1 with
  | [] => true
  | a :: l =>
    if in_dec dec a l2
    then included_dec dec l l2
    else false
  end.

(* substraction (minus) for decidable lists *)
Fixpoint minus_dec {T} (dec : Deq T) (l1 l2 : list T) :=
  match l1 with
  | [] => []
  | h :: t =>
    if in_dec dec h l2 then minus_dec dec t l2
    else h :: minus_dec dec t l2
  end.

(** intersection of 2 decidable lists *)
Fixpoint inter_dec {T} (dec : Deq T) (l1 l2 : list T) :=
  match l1 with
  | [] => []
  | h :: t =>
    if in_dec dec h l2 then h :: inter_dec dec t l2
    else inter_dec dec t l2
  end.

Lemma disj_dec_prop :
  forall {T} dec (l1 l2 : list T),
    disj_dec dec l1 l2 = true
    <-> disjoint l1 l2.
Proof.
  induction l1; simpl; introv; autorewrite with core;
    repeat (dest_cases w); try (rewrite IHl1); split; intro h; tcsp.
Qed.
Hint Rewrite @disj_dec_prop : core.

Lemma included_dec_prop :
  forall {T} dec (l1 l2 : list T),
    included_dec dec l1 l2 = true
    <-> subset l1 l2.
Proof.
  induction l1; simpl; introv; autorewrite with core;
    repeat (dest_cases w); try (rewrite IHl1); split; intro h; tcsp.
Qed.
Hint Rewrite @included_dec_prop : core.

Fixpoint fcset_disj {T} (dec : Deq T) (e1 e2 : FCset) : bool :=
  match e1, e2 with
  | FCS_finite   l1, FCS_finite   l2 => disj_dec dec l1 l2
  | FCS_finite   l1, FCS_infinite l2 => included_dec dec l1 l2
  | FCS_infinite l1, FCS_finite   l2 => included_dec dec l2 l1
  | FCS_infinite l1, FCS_infinite l2 => false
  end.

Definition fcset_subset {T} (dec : Deq T) (e1 e2 : FCset) : bool :=
  match e1, e2 with
  | FCS_finite   l1, FCS_finite   l2 => included_dec dec l1 l2
  | FCS_finite   l1, FCS_infinite l2 => disj_dec dec l1 l2
  | FCS_infinite l1, FCS_finite   l2 => false
  | FCS_infinite l1, FCS_infinite l2 => included_dec dec l2 l1
  end.

(** append 2 fcsets *)
Definition fcset_app {T} (dec : Deq T) (e1 e2 : FCset) : FCset :=
  match e1, e2 with
  | FCS_finite l1, FCS_finite l2 => FCS_finite (l1 ++ l2)
  | FCS_finite l1, FCS_infinite l2 => FCS_infinite (minus_dec dec l2 l1)
  | FCS_infinite l1, FCS_finite l2 => FCS_infinite (minus_dec dec l1 l2)
  | FCS_infinite l1, FCS_infinite l2 => FCS_infinite (inter_dec dec l1 l2)
  end.

(** intersection of 2 fcsets *)
Definition fcset_inter {T} (dec : Deq T) (e1 e2 : FCset) : FCset :=
  match e1, e2 with
  | FCS_finite l1, FCS_finite l2 => FCS_finite (inter_dec dec l1 l2)
  | FCS_finite l1, FCS_infinite l2 => FCS_finite (minus_dec dec l1 l2)
  | FCS_infinite l1, FCS_finite l2 => FCS_finite (minus_dec dec l2 l1)
  | FCS_infinite l1, FCS_infinite l2 => FCS_infinite (l1 ++ l2)
  end.

(** substraction of list from fcset *)
Definition fcset_remove_list
           {T}
           (dec : Deq T)
           (e : FCset)
           (vs : list T) : FCset :=
  match e with
  | FCS_finite l => FCS_finite (minus_dec dec l vs)
  | FCS_infinite l => FCS_infinite (l ++ vs)
  end.

(** substraction of one fcset form other *)
Fixpoint fcset_remove {T} (dec : Deq T) (l1 l2 : FCset) : FCset :=
  match l1, l2 with
  | FCS_finite l1, FCS_finite l2 => FCS_finite (minus_dec dec l1 l2)
  | FCS_infinite l1, FCS_finite l2 => FCS_infinite (l1 ++ l2)
  | FCS_finite l1, FCS_infinite l2 => FCS_finite (inter_dec dec l1 l2)
  | FCS_infinite l1, FCS_infinite l2 => FCS_finite (minus_dec dec l2 l1)
  end.

(*========= some FCset lemmas =========*)

(** a is in subtraction (minus) of two decidable lists,
than a is element of first list and it's not in second list *)
Lemma in_minus_dec :
  forall {T} (dec : Deq T) a l1 l2,
    List.In a (minus_dec dec l1 l2)
    <-> (List.In a l1 /\ ~ List.In a l2).
Proof.
  induction l1; introv; split; intro h; simpl in *;
    repnd; dands; auto;
      repeat (dest_cases w); auto;
        try (complete (simpl in *; repndors; subst; auto;
                       apply IHl1 in h; repnd; auto));
        simpl in *; repndors; subst; auto; tcsp.

  { apply IHl1; dands; auto. }

  { right; apply IHl1; dands; auto. }
Qed.

(** a is in intersection of two decidable lists,
then a is in both lists *)
Lemma in_inter_dec :
  forall {T} (dec : Deq T) a l1 l2,
    List.In a (inter_dec dec l1 l2)
    <-> (List.In a l1 /\ List.In a l2).
Proof.
  induction l1; introv; split; intro h; simpl in *;
    repnd; dands; auto;
      repeat (dest_cases w); auto;
        try (complete (simpl in *; repndors; subst; auto;
                       apply IHl1 in h; repnd; auto));
        tcsp; repndors; subst; simpl; tcsp.

  { right; apply IHl1; dands; auto. }

  { apply IHl1; dands; auto. }
Qed.

(**
  if a is not in intersection of two fcsets,
  then a is not element of either of them
 *)
Lemma in_fcset_app_false_implies :
  forall {T} (dec : Deq T) a e1 e2,
    in_fcset dec a (fcset_app dec e1 e2) = false
    ->
    (
      in_fcset dec a e1 = false
      /\
      in_fcset dec a e2 = false
    ).
Proof.
  destruct e1, e2; simpl; repeat (dest_cases w);
    allrw in_app_iff; introv h; allapply not_or; repnd; tcsp;
      dands; auto;
        try (complete (allrw @in_minus_dec; tcsp));
        try (complete (allrw @in_inter_dec; tcsp)).
Qed.

(**

 a is in intersectopn of two fcsets,
 iff a is element of one of them

 *)
Lemma in_fcset_app_true_iff :
  forall {T} (dec : Deq T) a e1 e2,
    in_fcset dec a (fcset_app dec e1 e2) = true
    <->
    (
      in_fcset dec a e1 = true
      \/
      in_fcset dec a e2 = true
    ).
Proof.
  destruct e1, e2; simpl; repeat (dest_cases w);
    allrw in_app_iff; repndors; split; intro h;
      auto; repndors; ginv;
        try (complete (allrw @in_minus_dec; tcsp));
        try (complete (allrw @in_inter_dec; tcsp)).
Qed.

(** v is in FCS_finite l iff v is in list l *)
Lemma in_fcset_finite :
  forall {T} (dec : Deq T) v l,
    in_fcset dec v (FCS_finite l) = true
    <-> List.In v l.
Proof.
  introv; simpl; dest_cases w; split; tcsp.
Qed.

Definition fcset_subset_list
           {T}
           (dec : Deq T)
           (e : FCset)
           (l : list T) : bool :=
  match e with
  | FCS_finite k => included_dec dec k l
  | FCS_infinite k => false
  end.

Lemma fset_subset_list_prop :
  forall {T} (dec : Deq T) e l a,
    fcset_subset_list dec e l = true
    -> in_fcset dec a e = true
    -> List.In a l.
Proof.
  destruct e; simpl; introv ss i; dest_cases w.
  eapply included_dec_prop; eauto.
Qed.

Lemma fcset_subset_prop :
  forall {T} (dec : Deq T) e1 e2 a,
    fcset_subset dec e1 e2 = true
    -> in_fcset dec a e1 = true
    -> in_fcset dec a e2 = true.
Proof.
  destruct e1, e2; simpl; introv ss i; repeat (dest_cases w); GC;
    autorewrite with core in *;
    try (complete (apply ss in i0; sp)).
Qed.

(** we need this in order to prove eassignables_subset_iff lemma *)
Definition FreshFun (T : Type) :=
  forall (l : list T), {x : T & not (List.In x l)}.

Lemma fcset_subset_iff :
  forall {T} (dec : Deq T) (fresh : FreshFun T) e1 e2,
    fcset_subset dec e1 e2 = true
    <-> (forall a, in_fcset dec a e1 = true -> in_fcset dec a e2 = true).
Proof.
  introv; split; introv h;
    try (introv q; eapply fcset_subset_prop; eauto).
  destruct e1, e2; simpl in *; autorewrite with core in *; tcsp.

  { introv i; pose proof (h v) as q; repeat (dest_cases w); autodimp q hyp; tcsp. }

  { introv i; pose proof (h v) as q; repeat (dest_cases w); autodimp q hyp; tcsp. }

  { pose proof (fresh (List.app l l0)) as q; exrepnd.
    allrw in_app_iff.
    apply not_or in q0; repnd.
    pose proof (h x) as q; clear h.
    repeat (dest_cases w). }

  { introv i.
    pose proof (h v) as q; clear h.
    repeat (dest_cases w).
    autodimp q hyp; tcsp. }
Qed.

(** we need this in order to prove eassignables_subset_iff lemma *)
Fixpoint append_string_list (l : list String.string) : String.string :=
  match l with
    | [] => ""
    | s :: l => String.append s (append_string_list l)
  end.

(** we need this in order to prove eassignables_subset_iff lemma *)
Lemma string_append_assoc :
  forall s1 s2 s3,
    String.append s1 (String.append s2 s3)
    = String.append (String.append s1 s2) s3.
Proof.
  induction s1; introv; allsimpl; auto.
  rw IHs1; auto.
Qed.

(** we need this in order to prove eassignables_subset_iff lemma *)
Lemma string_length_append :
  forall s1 s2,
    String.length (String.append s1 s2)
    = (String.length s1 + String.length s2)%nat.
Proof.
  induction s1; introv; allsimpl; auto.
Qed.

Lemma in_fcset_remove :
  forall {T} (dec : Deq T) a e1 e2,
    in_fcset dec a (fcset_remove dec e1 e2) = true
    <-> (in_fcset dec a e1 = true /\ not (in_fcset dec a e2 = true)).
Proof.
  destruct e1, e2; simpl; repeat (dest_cases w); split;
    intro h; tcsp; repnd; dands; tcsp;
      allrw @in_inter_dec;
      allrw @in_minus_dec;
      allrw in_app_iff;
      tcsp.
Qed.

Lemma included_dec_nil_implies :
  forall {T} (dec : Deq T) l, included_dec dec l [] = true -> l = [].
Proof.
  introv.
  destruct l; simpl; tcsp.
Qed.

Lemma fcset_subset_app_l_true_iff :
  forall {T} (dec : Deq T) (fresh : FreshFun T) e1 e2 e,
    fcset_subset dec (fcset_app dec e1 e2) e = true
    <-> (fcset_subset dec e1 e = true /\ fcset_subset dec e2 e = true).
Proof.
  introv fresh; introv.
  repeat (rewrite @fcset_subset_iff; auto); split; introv h; repnd; dands; introv i.
  { apply h; apply in_fcset_app_true_iff; sp. }
  { apply h; apply in_fcset_app_true_iff; sp. }
  { apply in_fcset_app_true_iff in i; repndors; tcsp. }
Qed.

Lemma implies_fcset_subset_app_r_true :
  forall {T} (dec : Deq T) (fresh : FreshFun T) e1 e2 e,
    (fcset_subset dec e e1 = true \/ fcset_subset dec e e2 = true)
    -> fcset_subset dec e (fcset_app dec e1 e2) = true.
Proof.
  introv fresh; introv.
  repeat (rewrite @fcset_subset_iff; auto); introv h i.
  apply in_fcset_app_true_iff; tcsp.
Qed.

Lemma fcset_subset_app_right :
  forall {T} (dec : Deq T) a b v,
    fcset_subset dec a v = true
    -> fcset_subset dec (fcset_app dec a b) (fcset_app dec v b) = true.
Proof.
  introv ss.
  destruct a, b, v; simpl in *;
    allrw @included_dec_prop;
    allrw @disj_dec_prop; ginv;
      try (complete (introv i; allrw @in_minus_dec; repnd; dands; auto)).

  { introv i; allrw in_app_iff; repndors; tcsp. }

  { introv i j; apply in_minus_dec in j; repnd.
    allrw in_app_iff; repndors; tcsp.
    apply ss in i; sp. }

  { introv i;
      allrw @in_minus_dec;
      allrw @in_inter_dec;
      repnd; dands; auto.
    intro j; apply ss in j; tcsp. }

  { introv i;
      allrw @in_inter_dec;
      repnd; dands; auto. }
Qed.

Lemma in_fcset_inter_iff :
  forall {T} (dec : Deq T) a e1 e2,
    in_fcset dec a (fcset_inter dec e1 e2) = true
    <-> (in_fcset dec a e1 = true /\ in_fcset dec a e2 = true).
Proof.
  destruct e1, e2; simpl; repeat (dest_cases w); auto;
    allrw @in_inter_dec;
    allrw @in_minus_dec;
    allrw in_app_iff;
    repnd; tcsp; split; introv xx; repnd; GC; tcsp.
Qed.

Lemma implies_fcset_subset_inter_l_true :
  forall {T} (dec : Deq T) (fresh : FreshFun T) e1 e2 e,
    (fcset_subset dec e1 e = true \/ fcset_subset dec e2 e = true)
    -> fcset_subset dec (fcset_inter dec e1 e2) e = true.
Proof.
  introv fresh h.
  rewrite fcset_subset_iff; auto.
  repeat (rewrite fcset_subset_iff in h; auto).
  introv i.
  apply in_fcset_inter_iff in i; repnd.
  repndors; apply h; auto.
Qed.

Lemma fcset_subset_refl :
  forall {T} (dec : Deq T) e, fcset_subset dec e e = true.
Proof.
  destruct e; simpl; auto; apply included_dec_prop; apply subset_refl.
Qed.

Lemma fcset_subset_trans :
  forall {T} (dec : Deq T) e1 e2 e3,
    fcset_subset dec e1 e2 = true
    -> fcset_subset dec e2 e3 = true
    -> fcset_subset dec e1 e3 = true.
Proof.
  destruct e1, e2, e3; introv h1 h2; simpl in *; tcsp;
    allrw @included_dec_prop;
    allrw @disj_dec_prop.

  { introv i; apply h1 in i; apply h2 in i; auto. }

  { introv i j; apply h1 in i; apply h2 in i; auto. }

  { introv i j; apply h1 in i; apply h2 in j; auto. }

  { introv i; apply h2 in i; apply h1 in i; auto. }
Qed.

Lemma fcset_subset_app_remove :
  forall {T} (dec : Deq T) e x,
    fcset_subset dec e (fcset_app dec (fcset_remove dec e x) x) = true.
Proof.
  destruct e, x; simpl;
    allrw @included_dec_prop;
    allrw @disj_dec_prop;
    introv i; allrw in_app_iff;
      allrw @in_minus_dec;
      allrw @in_inter_dec;
      allrw in_app_iff;
      tcsp.

  { destruct (in_dec dec v l0) as [d|d]; tcsp. }

  { repnd; destruct (in_dec dec v l) as [d|d]; tcsp.
    destruct i; sp. }
Qed.

Lemma minus_dec_app_r :
  forall {T} (dec : Deq T) l1 l2 l3,
    minus_dec dec l1 (l2 ++ l3)
    = minus_dec dec (minus_dec dec l1 l2) l3.
Proof.
  induction l1; introv; simpl; auto.
  repeat (repeat (dest_cases w); allrw in_app_iff; simpl);
    try (rewrite IHl1); auto;
      destruct n; tcsp.
Qed.

Lemma minus_dec_swap :
  forall {T} (dec : Deq T) l1 l2 l3,
    minus_dec dec (minus_dec dec l1 l2) l3
    = minus_dec dec (minus_dec dec l1 l3) l2.
Proof.
  induction l1; introv; simpl; auto.
  repeat (repeat (dest_cases w); allrw in_app_iff; simpl);
    try (rewrite IHl1); auto;
      destruct n; tcsp.
Qed.

Lemma minus_inter_dec_cancel_ss :
  forall {T} (dec : Deq T) l1 l2 l3,
    subset l1 l3
    -> minus_dec dec (inter_dec dec l1 l2) l3 = [].
Proof.
  induction l1; introv ss; simpl; auto.
  allrw @subset_cons_l; repnd.
  repeat (dest_cases w; simpl); simpl.
Qed.

Lemma minus_inter_dec_cancel :
  forall {T} (dec : Deq T) l1 l2,
    minus_dec dec (inter_dec dec l1 l2) l1 = [].
Proof.
  introv; apply minus_inter_dec_cancel_ss; auto.
Qed.

Lemma inter_minus_dec_swap :
  forall {T} (dec : Deq T) l1 l2 l3,
    inter_dec dec (minus_dec dec l1 l2) l3
    = minus_dec dec (inter_dec dec l1 l3) l2.
Proof.
  induction l1; introv; simpl; auto;
  repeat (repeat (dest_cases w); allrw in_app_iff; simpl);
  try (rewrite IHl1;clear IHl1); auto;
    rewrite minus_inter_dec_cancel; auto.
Qed.

Lemma inter_dec_nil_r :
  forall {T} (dec : Deq T) l, inter_dec dec l [] = [].
Proof.
  induction l; simpl; auto.
Qed.
Hint Rewrite @inter_dec_nil_r : core.

Lemma inter_dec_sym :
  forall {T} (dec : Deq T) l1 l2,
    eqset
      (inter_dec dec l1 l2)
      (inter_dec dec l2 l1).
Proof.
  introv; introv.
  repeat (rewrite @in_inter_dec).
  rewrite and_comm; sp.
Qed.

(** equality for FCsets *)
Definition fcset_eq {T} (dec : Deq T) (e1 e2 : FCset) : Prop :=
  (forall a, in_fcset dec a e1 = true <-> in_fcset dec a e2 = true).

Lemma fcset_eq_refl :
  forall {T} (dec : Deq T) e, fcset_eq dec e e.
Proof.
  introv; introv; sp.
Qed.
Hint Resolve fcset_eq_refl : core.

Lemma fcset_eq_FCS_infinite :
  forall {T} (dec : Deq T) l1 l2,
    fcset_eq dec (FCS_infinite l1) (FCS_infinite l2)
    <-> eqset l1 l2.
Proof.
  introv.
  unfold fcset_eq; simpl; split; intro h.
  - introv.
    pose proof (h x) as q; clear h; repeat (dest_cases w); split; intro h; tcsp.
    + destruct q as [q1 q2].
      autodimp q2 hyp; tcsp.
    + destruct q as [q1 q2].
      autodimp q2 hyp; tcsp.
  - introv.
    pose proof (h a) as q; clear h.
    repeat (dest_cases w); split; intro h; ginv.
    + apply q in i; tcsp.
    + apply q in i; tcsp.
Qed.

Lemma implies_eqset_minus_dec :
  forall {T} (dec : Deq T) l1 l2 l3 l4,
    eqset l1 l3
    -> eqset l2 l4
    -> eqset (minus_dec dec l1 l2) (minus_dec dec l3 l4).
Proof.
  introv eqs1 eqs2; introv.
  allrw @in_minus_dec.
  rewrite (eqs1 x).
  rewrite (eqs2 x); tcsp.
Qed.

Lemma inter_dec_assoc :
  forall {T} (dec : Deq T) l1 l2 l3,
    inter_dec dec (inter_dec dec l1 l2) l3
    = inter_dec dec l1 (inter_dec dec l2 l3).
Proof.
  induction l1; introv; simpl; auto.
  repeat (repeat (dest_cases w); allrw in_app_iff; simpl);
    try (rewrite IHl1); auto;
      allrw @in_inter_dec; repnd; tcsp.
  destruct n; tcsp.
Qed.

Lemma fcset_app_assoc :
  forall {T} (dec : Deq T) e1 e2 e3,
    fcset_eq
      dec
      (fcset_app dec (fcset_app dec e1 e2) e3)
      (fcset_app dec e1 (fcset_app dec e2 e3)).
Proof.
  destruct e1, e2, e3; simpl; auto.

  { rewrite app_assoc; eauto with core. }

  { rewrite minus_dec_app_r.
    rewrite minus_dec_swap; eauto with core. }

  { rewrite minus_dec_swap; eauto with core. }

  { rewrite inter_minus_dec_swap; eauto with core. }

  { rewrite minus_dec_app_r.
    rewrite minus_dec_swap; eauto with core. }

  { rewrite fcset_eq_FCS_infinite.
    eapply eqset_trans;[|apply inter_dec_sym].
    repeat (rewrite inter_minus_dec_swap).
    apply implies_eqset_minus_dec; eauto 3 with core.
    apply inter_dec_sym. }

  { rewrite fcset_eq_FCS_infinite.
    eapply eqset_trans;[|apply inter_dec_sym].
    repeat (rewrite inter_minus_dec_swap).
    apply implies_eqset_minus_dec; eauto 3 with core.
    apply inter_dec_sym. }

  { rewrite fcset_eq_FCS_infinite.
    rewrite inter_dec_assoc; auto. }
Qed.

Lemma minus_dec_nil_r :
  forall {T} (dec : Deq T) l, minus_dec dec l [] = l.
Proof.
  induction l; simpl; congruence.
Qed.
Hint Rewrite @minus_dec_nil_r : core.

Lemma fcset_app_nil_r :
  forall {T} (dec : Deq T) e, fcset_app dec e (FCS_finite []) = e.
Proof.
  destruct e; simpl; autorewrite with core; auto.
Qed.
Hint Rewrite @fcset_app_nil_r : core.

Lemma fcset_app_all_left :
  forall {T} (dec : Deq T) e,
    fcset_app dec (FCS_infinite []) e = FCS_infinite [].
Proof.
  destruct e; simpl; auto.
Qed.
Hint Rewrite @fcset_app_all_left : core.

Lemma fcset_app_all_right :
  forall {T} (dec : Deq T) e,
    fcset_app dec e (FCS_infinite []) = FCS_infinite [].
Proof.
  destruct e; simpl; auto.
  rewrite inter_dec_nil_r; auto.
Qed.
Hint Rewrite @fcset_app_all_right : core.

Lemma fcset_subset_all_implies :
  forall {T} (dec : Deq T) V,
    fcset_subset dec (FCS_infinite []) V = true
    -> V = FCS_infinite [].
Proof.
  destruct V; introv ss; simpl in *; ginv.
  apply included_dec_nil_implies in ss; subst; auto.
Qed.

Lemma fcset_disj_prop :
  forall {T} (dec : Deq T) e1 e2 x,
    fcset_disj dec e1 e2 = true
    -> in_fcset dec x e1 = true
    -> in_fcset dec x e2 = false.
Proof.
  destruct e1, e2;
    simpl; introv d i; repeat (dest_cases w); GC;
    allrw @disj_dec_prop;
    allrw @included_dec_prop;
    try (complete (apply d in i0; tcsp)).
Qed.

Lemma fcset_subset_nil_implies :
  forall {T} (dec : Deq T) e,
    fcset_subset dec e (FCS_finite []) = true
    -> e = FCS_finite [].
Proof.
  introv h.
  destruct e; simpl in *; ginv.
  apply included_dec_nil_implies in h; subst; auto.
Qed.

Lemma fcset_app_eq_nil_implies :
  forall {T} (dec : Deq T) a b,
    fcset_app dec a b = FCS_finite []
    -> (a = FCS_finite [] /\ b = FCS_finite []).
Proof.
  introv.
  destruct a, b; simpl; introv i; ginv.
  induction l; simpl in *; ginv.
Qed.

Lemma fcset_disj_sym :
  forall {T} (dec : Deq T) (e1 e2 : FCset),
    fcset_disj dec e1 e2 = true
    -> fcset_disj dec e2 e1 = true.
Proof.
  destruct e1, e2;
    unfold fcset_disj;
    simpl;
    allrw @disj_dec_prop;
    allrw @included_dec_prop;
    introv i; tcsp.
  apply disjoint_sym; auto.
Qed.

Lemma fcset_disj_app_l :
  forall {T} (dec : Deq T) e1 e2 e,
    fcset_disj dec (fcset_app dec e1 e2) e = true
    <-> (fcset_disj dec e1 e = true /\ fcset_disj dec e2 e = true).
Proof.
  destruct e1, e2, e;
    simpl;
    repeat (rewrite @disj_dec_prop);
    repeat (rewrite @included_dec_prop);
    repeat (rewrite disjoint_app_l);
    repeat (rewrite subset_app_l); tcsp;
      split; intro h; repnd; dands; tcsp;
        try (complete (introv i j; apply h in j; apply in_minus_dec in j; sp));
        try (complete (introv i; apply h in i; apply in_minus_dec in i; sp));
        try (complete (introv i; apply h in i; apply in_inter_dec in i; sp));
        try (complete (introv i; apply in_minus_dec; dands; auto; intro j; apply h in j; auto));
        try (complete (introv i; apply in_minus_dec; dands; auto; intro j; apply h0 in j; auto));
        try (complete (introv i; apply in_inter_dec; applydup h in i; apply h0 in i; sp)).
Qed.